summaryrefslogtreecommitdiff
path: root/src/Network/Torrent
diff options
context:
space:
mode:
Diffstat (limited to 'src/Network/Torrent')
-rw-r--r--src/Network/Torrent/PeerID.hs205
-rw-r--r--src/Network/Torrent/PeerWire.hs17
-rw-r--r--src/Network/Torrent/PeerWire/Block.hs56
-rw-r--r--src/Network/Torrent/PeerWire/Handshake.hs77
-rw-r--r--src/Network/Torrent/PeerWire/Message.hs91
-rw-r--r--src/Network/Torrent/Tracker.hs272
-rw-r--r--src/Network/Torrent/Tracker/Scrape.hs113
7 files changed, 0 insertions, 831 deletions
diff --git a/src/Network/Torrent/PeerID.hs b/src/Network/Torrent/PeerID.hs
deleted file mode 100644
index 7d928f80..00000000
--- a/src/Network/Torrent/PeerID.hs
+++ /dev/null
@@ -1,205 +0,0 @@
1-- TODO: tests
2-- |
3-- Copyright : (c) Sam T. 2013
4-- License : MIT
5-- Maintainer : pxqr.sta@gmail.com
6-- Stability : experimental
7-- Portability : non-portable
8--
9-- This module provides 'Peer' and 'PeerID' datatypes and all related
10-- operations.
11-- Recommended method for generation of the peer ID's is 'newPeerID',
12-- though this module exports some other goodies for custom generation.
13--
14{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving #-}
15module Network.Torrent.PeerID
16 ( -- * Peer addr
17 Peer(..)
18 , peerSockAddr, connectToPeer
19
20 -- * Peer identification
21 , PeerID (getPeerID)
22
23 -- ** Encoding styles
24 , azureusStyle, shadowStyle
25
26 -- ** Defaults
27 , defaultClientID, defaultVersionNumber
28
29 -- ** Generation
30 , newPeerID, timestampByteString
31 -- ** Extra
32
33 , byteStringPadded
34 ) where
35
36import Control.Applicative
37import Data.Word
38import Data.Bits
39import Data.BEncode
40import Data.ByteString (ByteString)
41import qualified Data.ByteString as B
42import qualified Data.ByteString.Char8 as BC
43import qualified Data.ByteString.Lazy as BL
44import qualified Data.ByteString.Builder as B
45import Data.Foldable (foldMap)
46import Data.Monoid ((<>))
47import Data.Serialize
48import Data.URLEncoded
49import Data.Version (Version(Version), versionBranch)
50import Data.Time.Clock (getCurrentTime)
51import Data.Time.Format (formatTime)
52import System.Locale (defaultTimeLocale)
53import Network
54import Network.Socket
55
56
57-- TODO we have linker error here, so manual hardcoded version for a while.
58-- import Paths_network_bittorrent (version)
59version :: Version
60version = Version [0, 10, 0, 0] []
61
62
63
64data Peer = Peer {
65 peerID :: Maybe PeerID
66 , peerIP :: HostAddress
67 , peerPort :: PortNumber
68 } deriving Show
69
70-- TODO make platform independent, clarify htonl
71-- | Convert peer info from tracker response to socket address.
72-- Used for establish connection between peers.
73--
74peerSockAddr :: Peer -> SockAddr
75peerSockAddr = SockAddrInet <$> (g . peerPort) <*> (htonl . peerIP)
76 where
77 htonl :: Word32 -> Word32
78 htonl d =
79 ((d .&. 0xff) `shiftL` 24) .|.
80 (((d `shiftR` 8 ) .&. 0xff) `shiftL` 16) .|.
81 (((d `shiftR` 16) .&. 0xff) `shiftL` 8) .|.
82 ((d `shiftR` 24) .&. 0xff)
83
84 g :: PortNumber -> PortNumber
85 g = id
86
87-- ipv6 extension
88-- | Tries to connect to peer using reasonable default parameters.
89--
90connectToPeer :: Peer -> IO Socket
91connectToPeer p = do
92 sock <- socket AF_INET Stream Network.Socket.defaultProtocol
93 connect sock (peerSockAddr p)
94 return sock
95
96
97-- | Peer identifier is exactly 20 bytes long bytestring.
98newtype PeerID = PeerID { getPeerID :: ByteString }
99 deriving (Show, Eq, Ord, BEncodable)
100
101instance Serialize PeerID where
102 put = putByteString . getPeerID
103 get = PeerID <$> getBytes 20
104
105instance URLShow PeerID where
106 urlShow = BC.unpack . getPeerID
107
108
109-- | Azureus-style encoding have the following layout:
110--
111-- * 1 byte : '-'
112--
113-- * 2 bytes: client id
114--
115-- * 4 bytes: version number
116--
117-- * 1 byte : '-'
118--
119-- * 12 bytes: random number
120--
121azureusStyle :: ByteString -- ^ 2 character client ID, padded with 'H'.
122 -> ByteString -- ^ Version number, padded with 'X'.
123 -> ByteString -- ^ Random number, padded with '0'.
124 -> PeerID -- ^ Azureus-style encoded peer ID.
125azureusStyle cid ver rnd = PeerID $ BL.toStrict $ B.toLazyByteString $
126 B.char8 '-' <>
127 byteStringPadded cid 2 'H' <>
128 byteStringPadded ver 4 'X' <>
129 B.char8 '-' <>
130 byteStringPadded rnd 12 '0'
131
132-- | Shadow-style encoding have the following layout:
133--
134-- * 1 byte : client id.
135--
136-- * 0-4 bytes: version number. If less than 4 then padded with '-' char.
137--
138-- * 15 bytes : random number. If length is less than 15 then padded with '0' char.
139--
140shadowStyle :: Char -- ^ Client ID.
141 -> ByteString -- ^ Version number.
142 -> ByteString -- ^ Random number.
143 -> PeerID -- ^ Shadow style encoded peer ID.
144shadowStyle cid ver rnd = PeerID $ BL.toStrict $ B.toLazyByteString $
145 B.char8 cid <>
146 byteStringPadded ver 4 '-' <>
147 byteStringPadded rnd 15 '0'
148
149
150-- | "HS" - 2 bytes long client identifier.
151defaultClientID :: ByteString
152defaultClientID = "HS"
153
154-- | Gives exactly 4 bytes long version number for any version of the package.
155-- Version is taken from .cabal.
156defaultVersionNumber :: ByteString
157defaultVersionNumber = B.take 4 (BC.pack (foldMap show (versionBranch version)))
158
159-- | Gives 15 characters long decimal timestamp such that:
160--
161-- * 6 bytes : first 6 characters from picoseconds obtained with %q.
162--
163-- * 1 bytes : character '.' for readability.
164--
165-- * 9..* bytes: number of whole seconds since the Unix epoch (!)REVERSED.
166--
167-- Can be used both with shadow and azureus style encoding. This format is
168-- used to make the ID's readable(for debugging) and more or less random.
169--
170timestampByteString :: IO ByteString
171timestampByteString = (BC.pack . format) <$> getCurrentTime
172 where
173 format t = take 6 (formatTime defaultTimeLocale "%q" t) ++ "." ++
174 take 9 (reverse (formatTime defaultTimeLocale "%s" t))
175
176-- | Here we use Azureus-style encoding with the following args:
177--
178-- * 'HS' for the client id.
179--
180-- * Version of the package for the version number
181--
182-- * UTC time day ++ day time for the random number.
183--
184newPeerID :: IO PeerID
185newPeerID = azureusStyle defaultClientID defaultVersionNumber
186 <$> timestampByteString
187
188-- | Pad bytestring so it's becomes exactly request length. Conversion is done
189-- like so:
190--
191-- * length < size: Complete bytestring by given charaters.
192--
193-- * length = size: Output bytestring as is.
194--
195-- * length > size: Drop last (length - size) charaters from a given bytestring.
196--
197byteStringPadded :: ByteString -- ^ bytestring to be padded.
198 -> Int -- ^ size of result builder.
199 -> Char -- ^ character used for padding.
200 -> B.Builder
201byteStringPadded bs s c =
202 B.byteString (B.take s bs) <>
203 B.byteString (BC.replicate padLen c)
204 where
205 padLen = s - min (B.length bs) s \ No newline at end of file
diff --git a/src/Network/Torrent/PeerWire.hs b/src/Network/Torrent/PeerWire.hs
deleted file mode 100644
index 887e56d5..00000000
--- a/src/Network/Torrent/PeerWire.hs
+++ /dev/null
@@ -1,17 +0,0 @@
1-- |
2-- Copyright : (c) Sam T. 2013
3-- License : MIT
4-- Maintainer : pxqr.sta@gmail.com
5-- Stability : experimental
6-- Portability : portable
7--
8{-# LANGUAGE DoAndIfThenElse #-}
9module Network.Torrent.PeerWire
10 ( module Network.Torrent.PeerWire.Block
11 , module Network.Torrent.PeerWire.Message
12 , module Network.Torrent.PeerWire.Handshake
13 ) where
14
15import Network.Torrent.PeerWire.Block
16import Network.Torrent.PeerWire.Message
17import Network.Torrent.PeerWire.Handshake
diff --git a/src/Network/Torrent/PeerWire/Block.hs b/src/Network/Torrent/PeerWire/Block.hs
deleted file mode 100644
index 056f6b18..00000000
--- a/src/Network/Torrent/PeerWire/Block.hs
+++ /dev/null
@@ -1,56 +0,0 @@
1module Network.Torrent.PeerWire.Block
2 ( BlockIx(..), Block(..)
3 , defaultBlockSize
4 , blockRange, ixRange, pieceIx
5 , isPiece
6 ) where
7
8import Data.ByteString (ByteString)
9import qualified Data.ByteString as B
10import Data.Int
11
12
13data BlockIx = BlockIx {
14 ixPiece :: {-# UNPACK #-} !Int -- ^ Zero-based piece index.
15 , ixOffset :: {-# UNPACK #-} !Int -- ^ Zero-based byte offset within the piece.
16 , ixLength :: {-# UNPACK #-} !Int -- ^ Block size starting from offset.
17 } deriving (Show, Eq)
18
19data Block = Block {
20 blkPiece :: Int -- ^ Zero-based piece index.
21 , blkOffset :: Int -- ^ Zero-based byte offset within the piece.
22 , blkData :: ByteString -- ^ Payload.
23 } deriving (Show, Eq)
24
25
26-- | Widely used semi-official block size.
27defaultBlockSize :: Int
28defaultBlockSize = 16 * 1024
29
30
31isPiece :: Int -> Block -> Bool
32isPiece pieceSize (Block i offset bs) =
33 offset == 0 && B.length bs == pieceSize && i >= 0
34{-# INLINE isPiece #-}
35
36pieceIx :: Int -> Int -> BlockIx
37pieceIx i = BlockIx i 0
38{-# INLINE pieceIx #-}
39
40blockRange :: (Num a, Integral a) => Int -> Block -> (a, a)
41blockRange pieceSize blk = (offset, offset + len)
42 where
43 offset = fromIntegral pieceSize * fromIntegral (blkPiece blk)
44 + fromIntegral (blkOffset blk)
45 len = fromIntegral (B.length (blkData blk))
46{-# INLINE blockRange #-}
47{-# SPECIALIZE blockRange :: Int -> Block -> (Int64, Int64) #-}
48
49ixRange :: (Num a, Integral a) => Int -> BlockIx -> (a, a)
50ixRange pieceSize ix = (offset, offset + len)
51 where
52 offset = fromIntegral pieceSize * fromIntegral (ixPiece ix)
53 + fromIntegral (ixOffset ix)
54 len = fromIntegral (ixLength ix)
55{-# INLINE ixRange #-}
56{-# SPECIALIZE ixRange :: Int -> BlockIx -> (Int64, Int64) #-}
diff --git a/src/Network/Torrent/PeerWire/Handshake.hs b/src/Network/Torrent/PeerWire/Handshake.hs
deleted file mode 100644
index 733d5785..00000000
--- a/src/Network/Torrent/PeerWire/Handshake.hs
+++ /dev/null
@@ -1,77 +0,0 @@
1-- |
2-- Copyright : (c) Sam T. 2013
3-- License : MIT
4-- Maintainer : pxqr.sta@gmail.com
5-- Stability : experimental
6-- Portability : portable
7--
8{-# LANGUAGE OverloadedStrings #-}
9module Network.Torrent.PeerWire.Handshake
10 ( Handshake
11 , handshakeMaxSize
12 , defaultBTProtocol, defaultReserved, defaultHandshake
13 , handshake
14 ) where
15
16import Control.Applicative
17import Data.Word
18import Data.ByteString (ByteString)
19import qualified Data.ByteString as B
20import Data.Serialize as S
21import Data.Torrent.InfoHash
22import Network
23import Network.Socket.ByteString
24import Network.Torrent.PeerID
25
26-- | In order to establish the connection between peers we should send 'Handshake'
27-- message. The 'Handshake' is a required message and must be the first message
28-- transmitted by the peer to the another peer.
29data Handshake = Handshake {
30 hsProtocol :: ByteString -- ^ Identifier of the protocol.
31 , hsReserved :: Word64 -- ^ Reserved bytes, rarely used.
32 , hsInfoHash :: InfoHash -- ^ Hash from the metainfo file.
33 -- This /should be/ same hash that is transmitted in tracker requests.
34 , hsPeerID :: PeerID -- ^ Peer id of the initiator.
35 -- This is /usually the same peer id that is transmitted in tracker requests.
36 } deriving (Show, Eq)
37
38instance Serialize Handshake where
39 put hs = do
40 putWord8 (fromIntegral (B.length (hsProtocol hs)))
41 putByteString (hsProtocol hs)
42 putWord64be (hsReserved hs)
43 put (hsInfoHash hs)
44 put (hsPeerID hs)
45
46 get = do
47 len <- getWord8
48 Handshake <$> getBytes (fromIntegral len)
49 <*> getWord64be
50 <*> get
51 <*> get
52
53-- | Maximum size of handshake message in bytes.
54handshakeMaxSize :: Int
55handshakeMaxSize = 1 + 256 + 8 + 20 + 20
56
57-- | Default protocol string "BitTorrent protocol" as is.
58defaultBTProtocol :: ByteString
59defaultBTProtocol = "BitTorrent protocol"
60
61-- | Default reserved word is 0.
62defaultReserved :: Word64
63defaultReserved = 0
64
65-- | Length of info hash and peer id is unchecked, so it /should/ be equal 20.
66defaultHandshake :: InfoHash -> PeerID -> Handshake
67defaultHandshake = Handshake defaultBTProtocol defaultReserved
68
69
70-- TODO check if hash the same
71-- | Handshaking with a peer specified by the second argument.
72--
73handshake :: Socket -> Handshake -> IO (Either String Handshake)
74handshake sock hs = do
75 sendAll sock (S.encode hs)
76 r <- recv sock handshakeMaxSize
77 return (S.decode r)
diff --git a/src/Network/Torrent/PeerWire/Message.hs b/src/Network/Torrent/PeerWire/Message.hs
deleted file mode 100644
index e04038ff..00000000
--- a/src/Network/Torrent/PeerWire/Message.hs
+++ /dev/null
@@ -1,91 +0,0 @@
1module Network.Torrent.PeerWire.Message
2 ( Message(..)
3 ) where
4
5import Control.Applicative
6import Data.ByteString (ByteString)
7import qualified Data.ByteString as B
8
9import Data.Serialize
10
11import Network.Torrent.PeerWire.Block
12
13
14-- TODO comment message constructors
15data Message = KeepAlive
16 | Choke
17 | Unchoke
18 | Interested
19 | NotInterested
20 | Have Int
21 | Bitfield ByteString
22 | Request BlockIx
23 | Piece Block
24 | Cancel BlockIx
25 | Port Int
26 deriving (Show, Eq)
27
28instance Serialize BlockIx where
29 {-# SPECIALIZE instance Serialize BlockIx #-}
30 get = BlockIx <$> getInt <*> getInt <*> getInt
31 {-# INLINE get #-}
32
33 put ix = do putInt (ixPiece ix)
34 putInt (ixOffset ix)
35 putInt (ixLength ix)
36 {-# INLINE put #-}
37
38instance Serialize Message where
39 get = do
40 len <- getInt
41 lookAhead $ ensure len
42 if len == 0 then return KeepAlive -- FIX check if BS is empty instead of reading len
43 else do
44 mid <- getWord8
45 case mid of
46 0 -> return Choke
47 1 -> return Unchoke
48 2 -> return Interested
49 3 -> return NotInterested
50 4 -> Have <$> getInt
51 5 -> Bitfield <$> getBytes (pred len)
52 6 -> Request <$> get
53 7 -> Piece <$> getBlock (len - 9)
54 8 -> Cancel <$> get
55 9 -> (Port . fromIntegral) <$> getWord16be
56 _ -> fail $ "unknown message ID: " ++ show mid
57
58 where
59 getBlock :: Int -> Get Block
60 getBlock len = Block <$> getInt <*> getInt <*> getBytes len
61 {-# INLINE getBlock #-}
62
63 put KeepAlive = putInt 0
64 put Choke = putInt 1 >> putWord8 0
65 put Unchoke = putInt 1 >> putWord8 1
66 put Interested = putInt 1 >> putWord8 2
67 put NotInterested = putInt 1 >> putWord8 3
68 put (Have i) = putInt 5 >> putWord8 4 >> putInt i
69 put (Bitfield b) = putInt l >> putWord8 5 >> putByteString b
70 where l = succ (B.length b)
71 {-# INLINE l #-}
72 put (Request blk) = putInt 13 >> putWord8 6 >> put blk
73 put (Piece blk) = putInt l >> putWord8 7 >> putBlock
74 where l = 9 + B.length (blkData blk)
75 {-# INLINE l #-}
76 putBlock = do putInt (blkPiece blk)
77 putInt (blkOffset blk)
78 putByteString (blkData blk)
79 {-# INLINE putBlock #-}
80
81 put (Cancel blk) = putInt 13 >> putWord8 8 >> put blk
82 put (Port p ) = putInt 3 >> putWord8 9 >> putWord16be (fromIntegral p)
83
84
85getInt :: Get Int
86getInt = fromIntegral <$> getWord32be
87{-# INLINE getInt #-}
88
89putInt :: Putter Int
90putInt = putWord32be . fromIntegral
91{-# INLINE putInt #-}
diff --git a/src/Network/Torrent/Tracker.hs b/src/Network/Torrent/Tracker.hs
deleted file mode 100644
index ffbdc949..00000000
--- a/src/Network/Torrent/Tracker.hs
+++ /dev/null
@@ -1,272 +0,0 @@
1-- TODO: add "compact" field to TRequest
2-- |
3-- Copyright : (c) Sam T. 2013
4-- License : MIT
5-- Maintainer : pxqr.sta@gmail.com
6-- Stability : experimental
7-- Portability : non-portable
8--
9{-# OPTIONS -fno-warn-orphans #-}
10{-# LANGUAGE OverloadedStrings #-}
11module Network.Torrent.Tracker
12 ( module Network.Torrent.Tracker.Scrape
13
14 -- * Requests
15 , Event(..), TRequest(..)
16 , startedReq, regularReq, stoppedReq, completedReq
17
18 -- * Responses
19 , TResponse(..)
20 , sendRequest
21
22 -- * Defaults
23 , defaultPorts, defaultNumWant
24 )
25 where
26
27import Network.Torrent.Tracker.Scrape
28
29import Control.Applicative
30import Data.Char as Char
31import Data.Word (Word32)
32import Data.List as L
33import Data.Map as M
34import Data.Monoid
35import Data.BEncode
36import Data.ByteString as B
37import Data.ByteString.Char8 as BC
38import Data.Text as T
39import Data.Serialize.Get hiding (Result)
40import Data.URLEncoded as URL
41import Data.Torrent
42
43import Network
44import Network.Socket
45import Network.HTTP
46import Network.URI
47import Network.Torrent.PeerID
48
49
50data Event = Started -- ^ For first request.
51 | Stopped -- ^ Sent when the peer is shutting down.
52 | Completed -- ^ To be sent when the peer completes a download.
53 deriving (Show, Read, Eq, Ord, Enum, Bounded)
54
55data TRequest = TRequest { -- TODO peer here -- TODO detach announce
56 reqAnnounce :: URI -- ^ Announce url of the torrent.
57 , reqInfoHash :: InfoHash -- ^ Hash of info part of the torrent.
58 , reqPeerID :: PeerID -- ^ Id of the peer doing request. ()
59 , reqPort :: PortNumber -- ^ Port to listen to for connection from other peers.
60 , reqUploaded :: Integer -- ^ # of bytes that the peer has uploaded in the swarm.
61 , reqDownloaded :: Integer -- ^ # of bytes downloaded in the swarm by the peer.
62 , reqLeft :: Integer -- ^ # of bytes needed in order to complete download.
63 , reqIP :: Maybe HostAddress -- ^ The peer IP.
64 , reqNumWant :: Maybe Int -- ^ Number of peers that the peers wants to receive from.
65 , reqEvent :: Maybe Event -- ^ If not specified,
66 -- the request is regular periodic request.
67 } deriving Show
68
69data TResponse =
70 Failure Text -- ^ Failure reason in human readable form.
71 | OK {
72 respWarning :: Maybe Text
73 , respInterval :: Int -- ^ Recommended interval to wait between requests.
74 , respMinInterval :: Maybe Int -- ^ Minimal amount of time between requests.
75 , respComplete :: Maybe Int -- ^ Number of peers completed the torrent. (seeders)
76 , respIncomplete :: Maybe Int -- ^ Number of peers downloading the torrent.
77 , respPeers :: [Peer] -- ^ Peers that must be contacted.
78 } deriving Show
79
80instance BEncodable PortNumber where
81 toBEncode = toBEncode . fromEnum
82 fromBEncode b = toEnum <$> fromBEncode b
83
84instance BEncodable Peer where
85 toBEncode (Peer pid pip pport) = fromAssocs
86 [ "peer id" -->? pid
87 , "ip" --> pip
88 , "port" --> pport
89 ]
90
91 fromBEncode (BDict d) =
92 Peer <$> d >--? "peer id"
93 <*> d >-- "ip"
94 <*> d >-- "port"
95
96 fromBEncode _ = decodingError "Peer"
97
98instance BEncodable TResponse where
99 toBEncode (Failure t) = fromAssocs ["failure reason" --> t]
100 toBEncode resp@(OK {}) = fromAssocs
101 [ "interval" --> respInterval resp
102 , "min interval" -->? respMinInterval resp
103 , "complete" -->? respComplete resp
104 , "incomplete" -->? respIncomplete resp
105 , "peers" --> respPeers resp
106 ]
107
108 fromBEncode (BDict d)
109 | Just t <- M.lookup "failure reason" d = Failure <$> fromBEncode t
110 | otherwise = OK <$> d >--? "warning message"
111 <*> d >-- "interval"
112 <*> d >--? "min interval"
113 <*> d >--? "complete"
114 <*> d >--? "incomplete"
115 <*> getPeers (M.lookup "peers" d)
116
117 where
118 getPeers :: Maybe BEncode -> Result [Peer]
119 getPeers (Just (BList l)) = fromBEncode (BList l)
120 getPeers (Just (BString s))
121 | B.length s `mod` 6 == 0 =
122 let cnt = B.length s `div` 6 in
123 runGet (sequence (L.replicate cnt peerG)) s
124 | otherwise = decodingError "peers length not a multiple of 6"
125 where
126 peerG = do
127 pip <- getWord32be
128 pport <- getWord16be
129 return (Peer Nothing (fromIntegral pip) (fromIntegral pport))
130
131 getPeers _ = decodingError "Peers"
132
133 fromBEncode _ = decodingError "TResponse"
134
135
136instance URLShow PortNumber where
137 urlShow = urlShow . fromEnum
138
139instance URLShow Word32 where
140 urlShow = show
141
142instance URLShow Event where
143 urlShow e = urlShow (Char.toLower x : xs)
144 where
145 -- this is always nonempty list
146 (x : xs) = show e
147
148instance URLEncode TRequest where
149 urlEncode req = mconcat
150 [ s "peer_id" %= reqPeerID req
151 , s "port" %= reqPort req
152 , s "uploaded" %= reqUploaded req
153 , s "downloaded" %= reqDownloaded req
154 , s "left" %= reqLeft req
155 , s "ip" %=? reqIP req
156 , s "numwant" %=? reqNumWant req
157 , s "event" %=? reqEvent req
158 ]
159 where s :: String -> String; s = id; {-# INLINE s #-}
160
161encodeRequest :: TRequest -> URI
162encodeRequest req = URL.urlEncode req
163 `addToURI` reqAnnounce req
164 `addHashToURI` reqInfoHash req
165
166
167-- | Ports typically reserved for bittorrent.
168defaultPorts :: [PortNumber]
169defaultPorts = [6881..6889]
170
171-- | Above 25, new peers are highly unlikely to increase download speed.
172-- Even 30 peers is _plenty_, the official client version 3 in fact only
173-- actively forms new connections if it has less than 30 peers and will
174-- refuse connections if it has 55. So default value is set to 25.
175--
176defaultNumWant :: Int
177defaultNumWant = 25
178
179
180-- | 'TSession' (shorthand for Tracker session) combines tracker request
181-- fields neccessary for tracker, torrent and client identification.
182-- This data is considered as static within one session.
183--
184data TSession = TSession {
185 tsesAnnounce :: URI -- ^ Announce URL.
186 , tsesInfoHash :: InfoHash -- ^ Hash of info part of current .torrent file.
187 , tsesPeerID :: PeerID -- ^ Client peer ID.
188 , tsesPort :: PortNumber -- ^ The port number the client is listenning on.
189 } deriving Show
190
191-- | 'Progress' contains upload/download/left stats about
192-- current client state.
193-- This data is considered as dynamic within one session.
194--
195data Progress = Progress {
196 prUploaded :: Integer -- ^ Total amount of bytes uploaded.
197 , prDownloaded :: Integer -- ^ Total amount of bytes downloaded.
198 , prLeft :: Integer -- ^ Total amount of bytes left.
199 } deriving Show
200
201-- | used to avoid boilerplate; do NOT export me
202genericReq :: TSession -> Progress -> TRequest
203genericReq ses pr = TRequest {
204 reqAnnounce = tsesAnnounce ses
205 , reqInfoHash = tsesInfoHash ses
206 , reqPeerID = tsesPeerID ses
207 , reqPort = tsesPort ses
208
209 , reqUploaded = prUploaded pr
210 , reqDownloaded = prDownloaded pr
211 , reqLeft = prLeft pr
212
213 , reqIP = Nothing
214 , reqNumWant = Nothing
215 , reqEvent = Nothing
216 }
217
218
219-- | The first request to the tracker that should be created is 'startedReq'.
220-- It includes necessary 'Started' event field.
221--
222startedReq :: TSession -> Progress -> TRequest
223startedReq ses pr = (genericReq ses pr) {
224 reqIP = Nothing
225 , reqNumWant = Just defaultNumWant
226 , reqEvent = Just Started
227 }
228
229-- | Regular request must be sent to keep track new peers and
230-- notify tracker about current state of the client
231-- so new peers could connect to the client.
232--
233regularReq :: Int -> TSession -> Progress -> TRequest
234regularReq numWant ses pr = (genericReq ses pr) {
235 reqIP = Nothing
236 , reqNumWant = Just numWant
237 , reqEvent = Nothing
238 }
239
240-- | Must be sent to the tracker if the client is shutting down gracefully.
241--
242stoppedReq :: TSession -> Progress -> TRequest
243stoppedReq ses pr = (genericReq ses pr) {
244 reqIP = Nothing
245 , reqNumWant = Nothing
246 , reqEvent = Just Stopped
247 }
248
249-- | Must be sent to the tracker when the download completes.
250-- However, must not be sent if the download was already 100% complete.
251--
252completedReq :: TSession -> Progress -> TRequest
253completedReq ses pr = (genericReq ses pr) {
254 reqIP = Nothing
255 , reqNumWant = Nothing
256 , reqEvent = Just Completed
257 }
258
259
260-- | TODO rename to ask for peers
261--
262sendRequest :: TRequest -> IO (Result TResponse)
263sendRequest req = do
264 let r = mkHTTPRequest (encodeRequest req)
265
266 rawResp <- simpleHTTP r
267 respBody <- getResponseBody rawResp
268 return (decoded (BC.pack respBody))
269
270 where
271 mkHTTPRequest :: URI -> Request String
272 mkHTTPRequest uri = Request uri GET [] ""
diff --git a/src/Network/Torrent/Tracker/Scrape.hs b/src/Network/Torrent/Tracker/Scrape.hs
deleted file mode 100644
index f5ebbea4..00000000
--- a/src/Network/Torrent/Tracker/Scrape.hs
+++ /dev/null
@@ -1,113 +0,0 @@
1-- |
2-- Copyright : (c) Sam T. 2013
3-- License : MIT
4-- Maintainer : pxqr.sta@gmail.com
5-- Stability : experimental
6-- Portability : portable
7--
8-- By convention most trackers support anouther form of request,
9-- which queries the state of a given torrent (or all torrents) that the
10-- tracker is managing. This module provides a way to easily request
11-- scrape info for a particular torrent list.
12--
13{-# LANGUAGE OverloadedStrings #-}
14module Network.Torrent.Tracker.Scrape
15 ( ScrapeInfo(..), Scrape
16 , scrapeURL
17
18 -- * Requests
19 , scrape
20 , scrapeOne
21 ) where
22
23import Control.Applicative
24import Data.BEncode
25import Data.ByteString (ByteString)
26import qualified Data.ByteString as B
27import qualified Data.ByteString.Char8 as BC
28import Data.Map (Map)
29import qualified Data.Map as M
30import Data.Monoid
31import Data.Torrent.InfoHash
32import Network.URI
33import Network.HTTP
34
35-- | Information about particular torrent.
36data ScrapeInfo = ScrapeInfo {
37 siComplete :: Int
38 -- ^ Number of seeders - peers with the entire file.
39 , siDownloaded :: Int
40 -- ^ Total number of times the tracker has registered a completion.
41 , siIncomplete :: Int
42 -- ^ Number of leechers.
43 , siName :: Maybe ByteString
44 -- ^ Name of the torrent file, as specified by the "name"
45 -- file in the info section of the .torrent file.
46 } deriving (Show, Eq)
47
48-- | Scrape info about a set of torrents.
49type Scrape = Map InfoHash ScrapeInfo
50
51instance BEncodable ScrapeInfo where
52 toBEncode si = fromAssocs
53 [ "complete" --> siComplete si
54 , "downloaded" --> siDownloaded si
55 , "incomplete" --> siIncomplete si
56 , "name" -->? siName si
57 ]
58
59 fromBEncode (BDict d) =
60 ScrapeInfo <$> d >-- "complete"
61 <*> d >-- "downloaded"
62 <*> d >-- "incomplete"
63 <*> d >--? "name"
64 fromBEncode _ = decodingError "ScrapeInfo"
65
66-- | Trying to convert /announce/ URL to /scrape/ URL. If 'scrapeURL'
67-- gives 'Nothing' then tracker do not support scraping. The info hash
68-- list is used to restrict the tracker's report to that particular
69-- torrents. Note that scrapping of multiple torrents may not be
70-- supported. (Even if scrapping convention is supported)
71--
72scrapeURL :: URI -> [InfoHash] -> Maybe URI
73scrapeURL uri ihs = do
74 newPath <- replace (BC.pack (uriPath uri))
75 let newURI = uri { uriPath = BC.unpack newPath }
76 return (foldl addHashToURI newURI ihs)
77 where
78 replace :: ByteString -> Maybe ByteString
79 replace p
80 | ps <- BC.splitWith (== '/') p
81 , "announce" `B.isPrefixOf` last ps
82 = let newSuff = "scrape" <> B.drop (B.length "announce") (last ps)
83 in Just (B.intercalate "/" (init ps ++ [newSuff]))
84 | otherwise = Nothing
85
86
87-- | For each 'InfoHash' of torrents request scrape info from the tracker.
88-- However if the info hash list is 'null', the tracker should list
89-- all available torrents.
90-- Note that the 'URI' should be /announce/ URI, not /scrape/ URI.
91--
92scrape :: URI -- ^ Announce 'URI'.
93 -> [InfoHash] -- ^ Torrents to be scrapped.
94 -> IO (Result Scrape) -- ^ 'ScrapeInfo' for each torrent.
95scrape announce ihs
96 | Just uri<- scrapeURL announce ihs = do
97 rawResp <- simpleHTTP (Request uri GET [] "")
98 respBody <- getResponseBody rawResp
99 return (decoded (BC.pack respBody))
100
101 | otherwise = return (Left "Tracker do not support scraping")
102
103-- | More particular version of 'scrape', just for one torrent.
104--
105scrapeOne :: URI -- ^ Announce 'URI'
106 -> InfoHash -- ^ Hash of the torrent info.
107 -> IO (Result ScrapeInfo) -- ^ 'ScrapeInfo' for the torrent.
108scrapeOne uri ih = extract <$> scrape uri [ih]
109 where
110 extract (Right m)
111 | Just s <- M.lookup ih m = Right s
112 | otherwise = Left "unable to find info hash in response dict"
113 extract (Left e) = Left e
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 22:18:49 +0000