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
|
{-# OPTIONS -fno-warn-orphans #-}
{-# LANGUAGE OverloadedStrings #-}
module Network.Torrent.THP
( Peer(..), Event(..), TRequest(..), TResponse(..)
, defaultRequest, defaultPorts
, sendRequest
)
where
import Control.Applicative
import Data.Char as Char
import Data.Word (Word32)
import Data.List as L
import Data.Map as M
import Data.Monoid
import Data.BEncode
import Data.ByteString as B
import Data.ByteString.Char8 as BC
import Data.Text as T
import Data.Serialize.Get hiding (Result)
import Data.URLEncoded as URL
import Network
import Network.Socket
import Network.HTTP
import Network.URI
import Network.Torrent.PeerID
import Numeric
type Hash = ByteString
data Peer = Peer {
peerID :: Maybe PeerID
, peerIP :: HostAddress
, peerPort :: PortNumber
} deriving Show
data Event = Started -- ^ For first request.
| Stopped -- ^ Sent when the peer is shutting down.
| Completed -- ^ To be sent when the peer completes a download.
deriving (Show, Read, Eq, Ord, Enum, Bounded)
data TRequest = TRequest { -- TODO peer here -- TODO detach announce
reqAnnounce :: URI -- ^ Announce url of the torrent.
, reqInfoHash :: Hash -- ^ Hash of info part of the torrent.
, reqPeerID :: PeerID -- ^ Id of the peer doing request. ()
, reqPort :: PortNumber -- ^ Port to listen to for connection from other peers.
, reqUploaded :: Int -- ^ # of bytes that the peer has uploaded in the swarm.
, reqDownloaded :: Int -- ^ # of bytes downloaded in the swarm by the peer.
, reqLeft :: Int -- ^ # of bytes needed in order to complete download.
, reqIP :: Maybe HostAddress -- ^ The peer IP.
, reqNumWant :: Maybe Int -- ^ Number of peers that the peers wants to receive from.
, reqEvent :: Maybe Event -- ^ If not specified,
-- the request is regular periodic request.
} deriving Show
data TResponse =
Failure Text -- ^ Failure reason in human readable form.
| OK {
respWarning :: Maybe Text
, respInterval :: Int -- ^ Recommended interval to wait between requests.
, respMinInterval :: Maybe Int -- ^ Minimal amount of time between requests.
, respComplete :: Maybe Int -- ^ Number of peers completed the torrent. (seeders)
, respIncomplete :: Maybe Int -- ^ Number of peers downloading the torrent.
, respPeers :: [Peer] -- ^ Peers that must be contacted.
} deriving Show
instance BEncodable PortNumber where
toBEncode = toBEncode . fromEnum
fromBEncode b = toEnum <$> fromBEncode b
instance BEncodable Peer where
toBEncode (Peer pid pip pport) = fromAssocs
[ "peer id" -->? pid
, "ip" --> pip
, "port" --> pport
]
fromBEncode (BDict d) =
Peer <$> d >--? "peer id"
<*> d >-- "ip"
<*> d >-- "port"
fromBEncode _ = decodingError "Peer"
instance BEncodable TResponse where
toBEncode (Failure t) = fromAssocs ["failure reason" --> t]
toBEncode resp@(OK {}) = fromAssocs
[ "interval" --> respInterval resp
, "min interval" -->? respMinInterval resp
, "complete" -->? respComplete resp
, "incomplete" -->? respIncomplete resp
, "peers" --> respPeers resp
]
fromBEncode (BDict d)
| Just t <- M.lookup "failure reason" d = Failure <$> fromBEncode t
| otherwise = OK <$> d >--? "warning message"
<*> d >-- "interval"
<*> d >--? "min interval"
<*> d >--? "complete"
<*> d >--? "incomplete"
<*> getPeers (M.lookup "peers" d)
where
getPeers :: Maybe BEncode -> Result [Peer]
getPeers (Just (BList l)) = fromBEncode (BList l)
getPeers (Just (BString s))
| B.length s `mod` 6 == 0 =
let cnt = B.length s `div` 6 in
runGet (sequence (L.replicate cnt peerG)) s
| otherwise = decodingError "peers length not a multiple of 6"
where
peerG = do
pip <- getWord32be
pport <- getWord16be
return (Peer Nothing (fromIntegral pip) (fromIntegral pport))
getPeers _ = decodingError "Peers"
fromBEncode _ = decodingError "TResponse"
instance URLShow PortNumber where
urlShow = urlShow . fromEnum
instance URLShow PeerID where
urlShow = BC.unpack . getPeerID
instance URLShow Word32 where
urlShow = show
instance URLShow Event where
urlShow e = urlShow (Char.toLower x : xs)
where
-- this is always nonempty list
(x : xs) = show e
instance URLEncode TRequest where
urlEncode req = mconcat
[ s "peer_id" %= reqPeerID req
, s "port" %= reqPort req
, s "uploaded" %= reqUploaded req
, s "downloaded" %= reqDownloaded req
, s "left" %= reqLeft req
, s "ip" %=? reqIP req
, s "numwant" %=? reqNumWant req
, s "event" %=? reqEvent req
]
where s :: String -> String; s = id; {-# INLINE s #-}
encodeRequest :: TRequest -> URI
encodeRequest req = URL.urlEncode req `addToURI` reqAnnounce req
`addHash` BC.unpack (reqInfoHash req)
where
addHash :: URI -> String -> URI
addHash uri s = uri { uriQuery = uriQuery uri ++ "&info_hash=" ++ rfc1738Encode s }
rfc1738Encode :: String -> String
rfc1738Encode = L.concatMap (\c -> if unreserved c then [c] else encode c)
where
unreserved = (`L.elem` chars)
chars = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_./"
encode :: Char -> String
encode c = '%' : pHex c
pHex c =
let p = (showHex . ord $ c) ""
in if L.length p == 1 then '0' : p else p
-- | Ports typically reserved for bittorrent.
defaultPorts :: [PortNumber]
defaultPorts = [6881..6889]
defaultRequest :: URI -> Hash -> PeerID -> TRequest
defaultRequest announce hash pid =
TRequest {
reqAnnounce = announce
, reqInfoHash = hash
, reqPeerID = pid
, reqPort = L.head defaultPorts
, reqUploaded = 0
, reqDownloaded = 0
, reqLeft = 0
, reqIP = Nothing
, reqNumWant = Just 25
, reqEvent = Just Started
}
-- | TODO rename to ask for peers
--
sendRequest :: TRequest -> IO (Result TResponse)
sendRequest req = do
let r = mkHTTPRequest (encodeRequest req)
print r
rawResp <- simpleHTTP r
respBody <- getResponseBody rawResp
print respBody
return (decoded (BC.pack respBody))
where
mkHTTPRequest :: URI -> Request String
mkHTTPRequest uri = Request uri GET [] ""
|
