summaryrefslogtreecommitdiff
path: root/src/Network/BitTorrent/Peer
diff options
context:
space:
mode:
Diffstat (limited to 'src/Network/BitTorrent/Peer')
-rw-r--r--src/Network/BitTorrent/Peer/Addr.hs83
-rw-r--r--src/Network/BitTorrent/Peer/ClientInfo.hs289
-rw-r--r--src/Network/BitTorrent/Peer/ID.hs168
-rw-r--r--src/Network/BitTorrent/Peer/Status.hs65
4 files changed, 0 insertions, 605 deletions
diff --git a/src/Network/BitTorrent/Peer/Addr.hs b/src/Network/BitTorrent/Peer/Addr.hs
deleted file mode 100644
index 5c05180a..00000000
--- a/src/Network/BitTorrent/Peer/Addr.hs
+++ /dev/null
@@ -1,83 +0,0 @@
1-- |
2-- Copyright : (c) Sam T. 2013
3-- License : MIT
4-- Maintainer : pxqr.sta@gmail.com
5-- Stability : experimental
6-- Portability : non-portable
7--
8{-# LANGUAGE OverloadedStrings #-}
9{-# LANGUAGE RecordWildCards #-}
10{-# OPTIONS -fno-warn-orphans #-}
11module Network.BitTorrent.Peer.Addr
12 ( PeerAddr(..)
13 , peerSockAddr, connectToPeer
14 , ppPeer
15 ) where
16
17import Control.Applicative
18import Data.BEncode
19import Data.Bits
20import Data.Word
21import Text.PrettyPrint
22import Network
23import Network.Socket
24
25import Network.BitTorrent.Peer.ID
26import Network.BitTorrent.Peer.ClientInfo
27
28
29data PeerAddr = PeerAddr {
30 peerID :: Maybe PeerID
31 , peerIP :: HostAddress
32 , peerPort :: PortNumber
33 } deriving (Show, Eq)
34
35instance BEncodable PortNumber where
36 toBEncode = toBEncode . fromEnum
37 fromBEncode b = toEnum <$> fromBEncode b
38
39instance BEncodable PeerAddr where
40 toBEncode (PeerAddr pid pip pport) = fromAssocs
41 [ "peer id" -->? pid
42 , "ip" --> pip
43 , "port" --> pport
44 ]
45
46 fromBEncode (BDict d) =
47 PeerAddr <$> d >--? "peer id"
48 <*> d >-- "ip"
49 <*> d >-- "port"
50
51 fromBEncode _ = decodingError "PeerAddr"
52
53
54-- TODO make platform independent, clarify htonl
55-- | Convert peer info from tracker response to socket address.
56-- Used for establish connection between peers.
57--
58peerSockAddr :: PeerAddr -> SockAddr
59peerSockAddr = SockAddrInet <$> (g . peerPort) <*> (htonl . peerIP)
60 where
61 htonl :: Word32 -> Word32
62 htonl d =
63 ((d .&. 0xff) `shiftL` 24) .|.
64 (((d `shiftR` 8 ) .&. 0xff) `shiftL` 16) .|.
65 (((d `shiftR` 16) .&. 0xff) `shiftL` 8) .|.
66 ((d `shiftR` 24) .&. 0xff)
67
68 g :: PortNumber -> PortNumber
69 g = id
70
71-- | Tries to connect to peer using reasonable default parameters.
72connectToPeer :: PeerAddr -> IO Socket
73connectToPeer p = do
74 sock <- socket AF_INET Stream Network.Socket.defaultProtocol
75 connect sock (peerSockAddr p)
76 return sock
77
78ppPeer :: PeerAddr -> Doc
79ppPeer p @ PeerAddr {..} = case peerID of
80 Just pid -> ppClientInfo (clientInfo pid) <+> "at" <+> paddr
81 Nothing -> paddr
82 where
83 paddr = text (show (peerSockAddr p))
diff --git a/src/Network/BitTorrent/Peer/ClientInfo.hs b/src/Network/BitTorrent/Peer/ClientInfo.hs
deleted file mode 100644
index 7200471a..00000000
--- a/src/Network/BitTorrent/Peer/ClientInfo.hs
+++ /dev/null
@@ -1,289 +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-- This module detect client information such as version and
9-- implementation that can be later printed in human frienly
10-- form. Useful for debugging and logging.
11--
12-- See <http://bittorrent.org/beps/bep_0020.html> for more
13-- information.
14--
15{-# LANGUAGE OverloadedStrings #-}
16{-# LANGUAGE RecordWildCards #-}
17module Network.BitTorrent.Peer.ClientInfo
18 ( -- * Info
19 ClientInfo(..), clientInfo, ppClientInfo, unknownClient
20
21 -- * Version
22 , ClientVersion, ppClientVersion
23
24 -- * Implementation
25 , ClientImpl(..), ppClientImpl
26
27-- , mkEnumTyDef, mkPars, nameMap
28 ) where
29
30import Control.Applicative
31--import Data.List
32import Data.ByteString (ByteString)
33import qualified Data.ByteString.Char8 as BC
34import Data.Serialize.Get
35import Text.PrettyPrint
36
37import Network.BitTorrent.Peer.ID
38
39
40-- | All known client versions.
41data ClientImpl =
42 IUnknown
43 | IAres
44 | IArctic
45 | IAvicora
46 | IBitPump
47 | IAzureus
48 | IBitBuddy
49 | IBitComet
50 | IBitflu
51 | IBTG
52 | IBitRocket
53 | IBTSlave
54 | IBittorrentX
55 | IEnhancedCTorrent
56 | ICTorrent
57 | IDelugeTorrent
58 | IPropagateDataClient
59 | IEBit
60 | IElectricSheep
61 | IFoxTorrent
62 | IGSTorrent
63 | IHalite
64 | IlibHSbittorrent
65 | IHydranode
66 | IKGet
67 | IKTorrent
68 | ILH_ABC
69 | ILphant
70 | ILibtorrent
71 | ILibTorrent
72 | ILimeWire
73 | IMonoTorrent
74 | IMooPolice
75 | IMiro
76 | IMoonlightTorrent
77 | INetTransport
78 | IPando
79 | IqBittorrent
80 | IQQDownload
81 | IQt4TorrentExample
82 | IRetriever
83 | IShareaza
84 | ISwiftbit
85 | ISwarmScope
86 | ISymTorrent
87 | Isharktorrent
88 | ITorrentDotNET
89 | ITransmission
90 | ITorrentstorm
91 | ITuoTu
92 | IuLeecher
93 | IuTorrent
94 | IVagaa
95 | IBitLet
96 | IFireTorrent
97 | IXunlei
98 | IXanTorrent
99 | IXtorrent
100 | IZipTorrent
101 deriving (Show, Eq, Ord)
102
103parseImpl :: ByteString -> ClientImpl
104parseImpl = f . BC.unpack
105 where
106 f "AG" = IAres
107 f "A~" = IAres
108 f "AR" = IArctic
109 f "AV" = IAvicora
110 f "AX" = IBitPump
111 f "AZ" = IAzureus
112 f "BB" = IBitBuddy
113 f "BC" = IBitComet
114 f "BF" = IBitflu
115 f "BG" = IBTG
116 f "BR" = IBitRocket
117 f "BS" = IBTSlave
118 f "BX" = IBittorrentX
119 f "CD" = IEnhancedCTorrent
120 f "CT" = ICTorrent
121 f "DE" = IDelugeTorrent
122 f "DP" = IPropagateDataClient
123 f "EB" = IEBit
124 f "ES" = IElectricSheep
125 f "FT" = IFoxTorrent
126 f "GS" = IGSTorrent
127 f "HL" = IHalite
128 f "HS" = IlibHSbittorrent
129 f "HN" = IHydranode
130 f "KG" = IKGet
131 f "KT" = IKTorrent
132 f "LH" = ILH_ABC
133 f "LP" = ILphant
134 f "LT" = ILibtorrent
135 f "lt" = ILibTorrent
136 f "LW" = ILimeWire
137 f "MO" = IMonoTorrent
138 f "MP" = IMooPolice
139 f "MR" = IMiro
140 f "MT" = IMoonlightTorrent
141 f "NX" = INetTransport
142 f "PD" = IPando
143 f "qB" = IqBittorrent
144 f "QD" = IQQDownload
145 f "QT" = IQt4TorrentExample
146 f "RT" = IRetriever
147 f "S~" = IShareaza
148 f "SB" = ISwiftbit
149 f "SS" = ISwarmScope
150 f "ST" = ISymTorrent
151 f "st" = Isharktorrent
152 f "SZ" = IShareaza
153 f "TN" = ITorrentDotNET
154 f "TR" = ITransmission
155 f "TS" = ITorrentstorm
156 f "TT" = ITuoTu
157 f "UL" = IuLeecher
158 f "UT" = IuTorrent
159 f "VG" = IVagaa
160 f "WT" = IBitLet
161 f "WY" = IFireTorrent
162 f "XL" = IXunlei
163 f "XT" = IXanTorrent
164 f "XX" = IXtorrent
165 f "ZT" = IZipTorrent
166 f _ = IUnknown
167
168-- | Format client implementation info in human readable form.
169ppClientImpl :: ClientImpl -> Doc
170ppClientImpl = text . tail . show
171
172unknownImpl :: ClientImpl
173unknownImpl = IUnknown
174
175
176
177type ClientVersion = ByteString
178
179-- | Format client implementation version in human readable form.
180ppClientVersion :: ClientVersion -> Doc
181ppClientVersion = text . BC.unpack
182
183unknownVersion :: ClientVersion
184unknownVersion = "0000"
185
186
187-- | All useful infomation that can be obtained from a peer
188-- identifier.
189data ClientInfo = ClientInfo {
190 ciImpl :: ClientImpl
191 , ciVersion :: ClientVersion
192 } deriving (Show, Eq, Ord)
193
194-- | Format client implementation in human readable form.
195ppClientInfo :: ClientInfo -> Doc
196ppClientInfo ClientInfo {..} =
197 ppClientImpl ciImpl <+> "version" <+> ppClientVersion ciVersion
198
199
200-- | Unrecognized client implementation.
201unknownClient :: ClientInfo
202unknownClient = ClientInfo unknownImpl unknownVersion
203
204-- | Tries to extract meaningful information from peer ID bytes. If
205-- peer id uses unknown coding style then client info returned is
206-- 'unknownClient'.
207--
208clientInfo :: PeerID -> ClientInfo
209clientInfo pid = either (const unknownClient) id $ runGet getCI (getPeerID pid)
210 where -- TODO other styles
211 getCI = do
212 _ <- getWord8
213 ClientInfo <$> (parseImpl <$> getByteString 2) <*> getByteString 4
214
215
216{-
217-- code used for generation; remove it later on
218
219mkEnumTyDef :: NM -> String
220mkEnumTyDef = unlines . map (" | I" ++) . nub . map snd
221
222mkPars :: NM -> String
223mkPars = unlines . map (\(code, impl) -> " f \"" ++ code ++ "\" = " ++ "I" ++ impl)
224
225type NM = [(String, String)]
226nameMap :: NM
227nameMap =
228 [ ("AG", "Ares")
229 , ("A~", "Ares")
230 , ("AR", "Arctic")
231 , ("AV", "Avicora")
232 , ("AX", "BitPump")
233 , ("AZ", "Azureus")
234 , ("BB", "BitBuddy")
235 , ("BC", "BitComet")
236 , ("BF", "Bitflu")
237 , ("BG", "BTG")
238 , ("BR", "BitRocket")
239 , ("BS", "BTSlave")
240 , ("BX", "BittorrentX")
241 , ("CD", "EnhancedCTorrent")
242 , ("CT", "CTorrent")
243 , ("DE", "DelugeTorrent")
244 , ("DP", "PropagateDataClient")
245 , ("EB", "EBit")
246 , ("ES", "ElectricSheep")
247 , ("FT", "FoxTorrent")
248 , ("GS", "GSTorrent")
249 , ("HL", "Halite")
250 , ("HS", "libHSnetwork_bittorrent")
251 , ("HN", "Hydranode")
252 , ("KG", "KGet")
253 , ("KT", "KTorrent")
254 , ("LH", "LH_ABC")
255 , ("LP", "Lphant")
256 , ("LT", "Libtorrent")
257 , ("lt", "LibTorrent")
258 , ("LW", "LimeWire")
259 , ("MO", "MonoTorrent")
260 , ("MP", "MooPolice")
261 , ("MR", "Miro")
262 , ("MT", "MoonlightTorrent")
263 , ("NX", "NetTransport")
264 , ("PD", "Pando")
265 , ("qB", "qBittorrent")
266 , ("QD", "QQDownload")
267 , ("QT", "Qt4TorrentExample")
268 , ("RT", "Retriever")
269 , ("S~", "Shareaza")
270 , ("SB", "Swiftbit")
271 , ("SS", "SwarmScope")
272 , ("ST", "SymTorrent")
273 , ("st", "sharktorrent")
274 , ("SZ", "Shareaza")
275 , ("TN", "TorrentDotNET")
276 , ("TR", "Transmission")
277 , ("TS", "Torrentstorm")
278 , ("TT", "TuoTu")
279 , ("UL", "uLeecher")
280 , ("UT", "uTorrent")
281 , ("VG", "Vagaa")
282 , ("WT", "BitLet")
283 , ("WY", "FireTorrent")
284 , ("XL", "Xunlei")
285 , ("XT", "XanTorrent")
286 , ("XX", "Xtorrent")
287 , ("ZT", "ZipTorrent")
288 ]
289-} \ No newline at end of file
diff --git a/src/Network/BitTorrent/Peer/ID.hs b/src/Network/BitTorrent/Peer/ID.hs
deleted file mode 100644
index 9bf0ae31..00000000
--- a/src/Network/BitTorrent/Peer/ID.hs
+++ /dev/null
@@ -1,168 +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--
12-- Recommended method for generation of the peer ID's is 'newPeerID',
13-- though this module exports some other goodies for custom generation.
14--
15{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving #-}
16module Network.BitTorrent.Peer.ID
17 ( -- * Peer identification
18 PeerID (getPeerID), ppPeerID
19
20 -- ** Encoding styles
21 , azureusStyle, shadowStyle
22
23 -- ** Defaults
24 , defaultClientID, defaultVersionNumber
25
26 -- ** Generation
27 , newPeerID, timestampByteString
28 -- ** Extra
29
30 , byteStringPadded
31 ) where
32
33import Control.Applicative
34import Data.BEncode
35import Data.ByteString (ByteString)
36import qualified Data.ByteString as B
37import qualified Data.ByteString.Char8 as BC
38import qualified Data.ByteString.Lazy as BL
39import qualified Data.ByteString.Builder as B
40import Data.Foldable (foldMap)
41import Data.Monoid ((<>))
42import Data.Serialize
43import Data.URLEncoded
44import Data.Version (Version(Version), versionBranch)
45import Data.Time.Clock (getCurrentTime)
46import Data.Time.Format (formatTime)
47import Text.PrettyPrint (text, Doc)
48import System.Locale (defaultTimeLocale)
49
50
51-- TODO we have linker error here, so manual hardcoded version for a while.
52-- import Paths_network_bittorrent (version)
53version :: Version
54version = Version [0, 10, 0, 0] []
55
56
57-- | Peer identifier is exactly 20 bytes long bytestring.
58newtype PeerID = PeerID { getPeerID :: ByteString }
59 deriving (Show, Eq, Ord, BEncodable)
60
61instance Serialize PeerID where
62 put = putByteString . getPeerID
63 get = PeerID <$> getBytes 20
64
65instance URLShow PeerID where
66 urlShow = BC.unpack . getPeerID
67
68ppPeerID :: PeerID -> Doc
69ppPeerID = text . BC.unpack . getPeerID
70
71
72-- | Azureus-style encoding have the following layout:
73--
74-- * 1 byte : '-'
75--
76-- * 2 bytes: client id
77--
78-- * 4 bytes: version number
79--
80-- * 1 byte : '-'
81--
82-- * 12 bytes: random number
83--
84azureusStyle :: ByteString -- ^ 2 character client ID, padded with 'H'.
85 -> ByteString -- ^ Version number, padded with 'X'.
86 -> ByteString -- ^ Random number, padded with '0'.
87 -> PeerID -- ^ Azureus-style encoded peer ID.
88azureusStyle cid ver rnd = PeerID $ BL.toStrict $ B.toLazyByteString $
89 B.char8 '-' <>
90 byteStringPadded cid 2 'H' <>
91 byteStringPadded ver 4 'X' <>
92 B.char8 '-' <>
93 byteStringPadded rnd 12 '0'
94
95-- | Shadow-style encoding have the following layout:
96--
97-- * 1 byte : client id.
98--
99-- * 0-4 bytes: version number. If less than 4 then padded with '-' char.
100--
101-- * 15 bytes : random number. If length is less than 15 then padded with '0' char.
102--
103shadowStyle :: Char -- ^ Client ID.
104 -> ByteString -- ^ Version number.
105 -> ByteString -- ^ Random number.
106 -> PeerID -- ^ Shadow style encoded peer ID.
107shadowStyle cid ver rnd = PeerID $ BL.toStrict $ B.toLazyByteString $
108 B.char8 cid <>
109 byteStringPadded ver 4 '-' <>
110 byteStringPadded rnd 15 '0'
111
112
113-- | "HS" - 2 bytes long client identifier.
114defaultClientID :: ByteString
115defaultClientID = "HS"
116
117-- | Gives exactly 4 bytes long version number for any version of the package.
118-- Version is taken from .cabal.
119defaultVersionNumber :: ByteString
120defaultVersionNumber = B.take 4 (BC.pack (foldMap show (versionBranch version)))
121
122-- | Gives 15 characters long decimal timestamp such that:
123--
124-- * 6 bytes : first 6 characters from picoseconds obtained with %q.
125--
126-- * 1 bytes : character '.' for readability.
127--
128-- * 9..* bytes: number of whole seconds since the Unix epoch (!)REVERSED.
129--
130-- Can be used both with shadow and azureus style encoding. This format is
131-- used to make the ID's readable(for debugging) and more or less random.
132--
133timestampByteString :: IO ByteString
134timestampByteString = (BC.pack . format) <$> getCurrentTime
135 where
136 format t = take 6 (formatTime defaultTimeLocale "%q" t) ++ "." ++
137 take 9 (reverse (formatTime defaultTimeLocale "%s" t))
138
139-- | Here we use Azureus-style encoding with the following args:
140--
141-- * 'HS' for the client id.
142--
143-- * Version of the package for the version number
144--
145-- * UTC time day ++ day time for the random number.
146--
147newPeerID :: IO PeerID
148newPeerID = azureusStyle defaultClientID defaultVersionNumber
149 <$> timestampByteString
150
151-- | Pad bytestring so it's becomes exactly request length. Conversion is done
152-- like so:
153--
154-- * length < size: Complete bytestring by given charaters.
155--
156-- * length = size: Output bytestring as is.
157--
158-- * length > size: Drop last (length - size) charaters from a given bytestring.
159--
160byteStringPadded :: ByteString -- ^ bytestring to be padded.
161 -> Int -- ^ size of result builder.
162 -> Char -- ^ character used for padding.
163 -> B.Builder
164byteStringPadded bs s c =
165 B.byteString (B.take s bs) <>
166 B.byteString (BC.replicate padLen c)
167 where
168 padLen = s - min (B.length bs) s \ No newline at end of file
diff --git a/src/Network/BitTorrent/Peer/Status.hs b/src/Network/BitTorrent/Peer/Status.hs
deleted file mode 100644
index 806ba77d..00000000
--- a/src/Network/BitTorrent/Peer/Status.hs
+++ /dev/null
@@ -1,65 +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--
8module Network.BitTorrent.Peer.Status
9 ( PeerStatus(..)
10 , setChoking, setInterested
11 , initPeerStatus
12
13 , SessionStatus(..)
14 , initSessionStatus
15 , setClientStatus, setPeerStatus
16 , canUpload, canDownload
17
18 -- * Defaults
19 , defaultUnchokeSlots
20 ) where
21
22data PeerStatus = PeerStatus {
23 psChoking :: Bool
24 , psInterested :: Bool
25 }
26
27-- | Any session between peers starts as choking and not interested.
28initPeerStatus :: PeerStatus
29initPeerStatus = PeerStatus True False
30
31setChoking :: Bool -> PeerStatus -> PeerStatus
32setChoking b ps = ps { psChoking = b }
33
34setInterested :: Bool -> PeerStatus -> PeerStatus
35setInterested b ps = ps { psInterested = b }
36
37
38
39data SessionStatus = SessionStatus {
40 seClientStatus :: PeerStatus
41 , sePeerStatus :: PeerStatus
42 }
43
44initSessionStatus :: SessionStatus
45initSessionStatus = SessionStatus initPeerStatus initPeerStatus
46
47setClientStatus :: (PeerStatus -> PeerStatus) -> SessionStatus -> SessionStatus
48setClientStatus f ss = ss { seClientStatus = f (seClientStatus ss) }
49
50setPeerStatus :: (PeerStatus -> PeerStatus) -> SessionStatus -> SessionStatus
51setPeerStatus f ss = ss { sePeerStatus = f (sePeerStatus ss) }
52
53-- | Can the /client/ to upload to the /peer/?
54canUpload :: SessionStatus -> Bool
55canUpload SessionStatus { seClientStatus = client, sePeerStatus = peer} =
56 psInterested peer && not (psChoking client)
57
58-- | Can the /client/ download from the /peer/?
59canDownload :: SessionStatus -> Bool
60canDownload SessionStatus { seClientStatus = client, sePeerStatus = peer } =
61 psInterested client && not (psChoking peer)
62
63-- | Indicates have many peers are allowed to download from the client.
64defaultUnchokeSlots :: Int
65defaultUnchokeSlots = 4 \ No newline at end of file
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-13 17:45:17 +0000