Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP

Loading…

multiple trackers support (BEP0012) + metadata encoding fix #39

Merged
merged 4 commits into from

2 participants

@nikmikov

Here is my few cents to Combinatorrent:
1. Support ghc 7.4.1
2. Correct parsing of the metadata files, that contain file names encoded with multibyte characters
3. Multiple trackers support (BEP0012)

@jlouis jlouis merged commit 7874f79 into jlouis:master
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
Commits on Apr 21, 2012
  1. @nikmikov
Commits on May 6, 2012
  1. @nikmikov

    fixes #3

    nikmikov authored
Commits on May 7, 2012
  1. @nikmikov
Commits on May 12, 2012
  1. @nikmikov
This page is out of date. Refresh to see the latest.
View
5 Combinatorrent.cabal
@@ -18,7 +18,7 @@ author: Jesper Louis Andersen
maintainer: jesper.louis.andersen@gmail.com
stability: experimental
synopsis: A concurrent bittorrent client
-tested-with: GHC ==6.12.1, GHC ==6.12.2, GHC ==6.13.20100426
+tested-with: GHC ==6.12.1, GHC ==6.12.2, GHC ==6.13.20100426, GHC == 7.4.1
build-type: Configure
extra-tmp-files: src/Version.hs
@@ -27,7 +27,7 @@ data-files: AUTHORS, README.md
flag debug
description: Enable debug support
- default: False
+ default: True
flag threaded
description: Build with threaded runtime
@@ -85,6 +85,7 @@ executable Combinatorrent
test-framework,
test-framework-hunit,
test-framework-quickcheck2,
+ text,
time
ghc-options: -Wall -fno-warn-orphans -funbox-strict-fields
View
1  src/Channels.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
module Channels
( Peer(..)
, PeerChokeMsg(..)
View
7 src/Digest.hs
@@ -7,15 +7,10 @@ module Digest
)
where
-import Control.Applicative
import Control.DeepSeq
-import Control.Monad.State
-import Data.Word
-
-import Foreign.Ptr
import qualified Data.ByteString as B
-import Data.ByteString.Unsafe
+
import qualified Data.ByteString.Lazy as L
import qualified Crypto.Hash.SHA1 as SHA1
View
2  src/Process/Peer.hs
@@ -29,7 +29,7 @@ import qualified Data.PieceSet as PS
import Data.Maybe
import Data.Monoid(Monoid(..), Last(..))
-import Data.Set as S hiding (map)
+import Data.Set as S hiding (map, foldl)
import Data.Time.Clock
import Data.Word
View
103 src/Process/Tracker.hs
@@ -13,6 +13,7 @@ module Process.Tracker
)
where
+import Prelude hiding (catch)
import Control.Applicative
import Control.Concurrent
import Control.Concurrent.STM
@@ -27,8 +28,11 @@ import Data.Word
import Network.Socket as S
import Network.HTTP hiding (port)
import Network.URI hiding (unreserved)
+import Network.Stream
-import Protocol.BCode as BCode hiding (encode)
+import Control.Exception
+
+import Protocol.BCode as BCode hiding (encode, announceList)
import Process
import Channels
import Supervisor
@@ -83,6 +87,7 @@ instance Logging CF where
-- | Internal state of the tracker CHP process
data ST = ST {
torrentInfo :: TorrentInfo
+ , announceList :: [[AnnounceURL]] -- will store it separate from TorrentInfo as it could be updated
, peerId :: PeerId
, state :: TrackerEvent
, localPort :: Word16
@@ -93,7 +98,7 @@ start :: InfoHash -> TorrentInfo -> PeerId -> Word16
-> Status.StatusChannel -> TrackerChannel -> PeerMgr.PeerMgrChannel
-> SupervisorChannel -> IO ThreadId
start ih ti pid port statusC msgC pc supC =
- spawnP (CF statusC msgC pc ih) (ST ti pid Stopped port 0)
+ spawnP (CF statusC msgC pc ih) (ST ti (announceURLs ti) pid Stopped port 0)
({-# SCC "Tracker" #-} cleanupP loop
(defaultStopHandler supC)
stopEvent)
@@ -112,7 +117,7 @@ start ih ti pid port statusC msgC pc supC =
Start ->
modify (\s -> s { state = Started }) >> talkTracker
Complete ->
- modify (\s -> s { state = Completed }) >> talkTracker
+ modify (\s -> s { state = Completed }) >> talkTracker
loop
talkTracker = pokeTracker >>= timerUpdate
@@ -135,12 +140,7 @@ pokeTracker = do
asks statusPCh >>=
(\ch -> liftIO . atomically $ writeTChan ch (Status.RequestStatus ih v))
upDownLeft <- liftIO . atomically $ takeTMVar v
- url <- buildRequestURL upDownLeft
- debugP $ "Request URL: " ++ url
- uri <- case parseURI url of
- Nothing -> fail $ "Could not parse the url " ++ url
- Just u -> return u
- resp <- trackerRequest uri
+ resp <- queryTrackers upDownLeft
case resp of
Left err -> do infoP $ "Tracker HTTP Error: " ++ err
return (failTimerInterval, Just failTimerInterval)
@@ -234,12 +234,69 @@ cW128 bs =
(q3, q4) = B.splitAt 4 r2
in (cW32 q1, cW32 q2, cW32 q3, cW32 q4)
+
+
+bubbleUpURL :: AnnounceURL -> [AnnounceURL] -> Process CF ST ()
+bubbleUpURL _ (_:[]) = return ()
+bubbleUpURL _ [] = return ()
+bubbleUpURL url tier@(x:_) = if url == x
+ then return ()
+ else do
+ alist <- gets announceList
+ let newTier = url : filter (/=url) tier
+ newAnnounceList = map (\a -> if a /= tier then a else newTier) alist
+ _ <- modify (\s -> s { announceList = newAnnounceList })
+ return ()
+
+tryThisTier' :: Status.StatusState -> [AnnounceURL] -> Process CF ST (Either String (AnnounceURL, TrackerResponse))
+tryThisTier' _ [] = return $ Left "Empty announce-list"
+tryThisTier' s (x:xs) = do url <- buildRequestURL s x
+ uri <- case parseURI url of
+ Nothing -> fail $ "Could not parse the url " ++ url
+ Just u -> return u
+ resp <- trackerRequest uri
+ case resp of
+ Left m -> if null xs
+ then return $ Left m
+ else tryThisTier' s xs
+ Right r -> return $ Right (x, r)
+
+
+-- | from BEP0012: try first element in list, if it's can't be reached, then second, and so on
+-- first successfull URL will bubble up and become the new head of this tier
+-- announceList stored in State should be updated to reflect the changes
+tryThisTier :: Status.StatusState -> [AnnounceURL] -> Process CF ST (Either String TrackerResponse)
+tryThisTier params tier = do resp <- tryThisTier' params tier
+ case resp of
+ Left m -> return $ Left m
+ Right (url, r) -> do bubbleUpURL url tier
+ return $ Right r
+
+
+queryTrackers' :: Status.StatusState -> [[AnnounceURL]] -> Process CF ST (Either String TrackerResponse)
+queryTrackers' _ [] = return $ Left "Empty announce-list"
+queryTrackers' p (x:[]) = tryThisTier p x --last element, so return whatever it gives us
+queryTrackers' p (x:xs) = do resp <- tryThisTier p x
+ case resp of
+ Left _ -> queryTrackers' p xs -- in case of error, move to the next tier
+ Right _ -> return $ resp -- if success just return result
+
+queryTrackers :: Status.StatusState -> Process CF ST (Either String TrackerResponse)
+queryTrackers ss = do alist <- gets announceList
+ queryTrackers' ss alist
+
+
+
-- TODO: Do not recurse infinitely here.
trackerRequest :: URI -> Process CF ST (Either String TrackerResponse)
trackerRequest uri =
- do resp <- liftIO $ simpleHTTP request
+ do debugP $ "Querying URI: " ++ (show uri)
+ resp <- liftIO $ catch (simpleHTTP request) (\e -> let err = show (e :: IOException)
+ in return . Left . ErrorMisc $ err)
case resp of
- Left x -> return $ Left ("Error connecting: " ++ show x)
+ Left x -> do let err = "Error connecting: " ++ show x
+ debugP err
+ return $ Left err
Right r ->
case rspCode r of
(2,_,_) ->
@@ -259,18 +316,18 @@ trackerRequest uri =
rqHeaders = [],
rqBody = ""}
--- Construct a new request URL. Perhaps this ought to be done with the HTTP
--- client library
-buildRequestURL :: Status.StatusState -> Process CF ST String
-buildRequestURL ss = do ti <- gets torrentInfo
- params <- urlEncodeVars <$> buildRequestParams ss
- let announceString = fromBS $ announceURL ti
- -- announce string might already have some
- -- parameters in it
- sep = if '?' `elem` announceString
- then "&"
- else "?"
- return $ concat [announceString, sep, params]
+--- Construct a new request URL. Perhaps this ought to be done with the HTTP
+--- client library
+buildRequestURL :: Status.StatusState -> AnnounceURL -> Process CF ST String
+buildRequestURL ss url = do params <- urlEncodeVars <$> buildRequestParams ss
+ let announceString = fromBS url
+ -- announce string might already have some
+ -- parameters in it
+ sep = if '?' `elem` announceString
+ then "&"
+ else "?"
+ return $ concat [announceString, sep, params]
+
buildRequestParams :: Status.StatusState -> Process CF ST [(String, String)]
buildRequestParams ss = do
View
22 src/Protocol/BCode.hs
@@ -11,6 +11,7 @@ module Protocol.BCode
announce,
comment,
creationDate,
+ announceList,
info,
hashInfoDict,
infoLength,
@@ -44,6 +45,9 @@ import Control.Applicative hiding (many)
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString as B
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as T
+
import Data.Char
import Data.List
@@ -97,6 +101,9 @@ toBS = B.pack . map toW8
fromBS :: B.ByteString -> String
fromBS = map fromW8 . B.unpack
+fromUtf8BS :: B.ByteString -> String
+fromUtf8BS = T.unpack . T.decodeUtf8
+
instance Serialize BCode where
put (BInt i) = wrap 'i' 'e' $ putShow i
@@ -242,6 +249,15 @@ announce = search' "announce"
comment = search' "comment"
creationDate = search' "creation date"
+
+-- | list of list of strings, according to official spec
+announceList :: BCode -> Maybe [[B.ByteString]]
+announceList b = case search [toPS "announce-list"] b of
+ Just (BArray xs) -> Just ( map (\(BArray s) -> map' s) xs)
+ _ -> Nothing
+ where map' = map (\(BString s) -> s)
+
+
{- Tracker accessors -}
trackerComplete, trackerIncomplete, trackerInterval :: BCode -> Maybe Integer
trackerMinInterval :: BCode -> Maybe Integer
@@ -295,13 +311,13 @@ numberPieces :: BCode -> Maybe Int
numberPieces = fmap length . infoPieces
infoFiles :: BCode -> Maybe [([String], Integer)] -- ^[(filePath, fileLength)]
-infoFiles bc = let mbFpath = fromBS `fmap` infoName bc
+infoFiles bc = let mbFpath = fromUtf8BS `fmap` infoName bc
mbLength = infoLength bc
mbFiles = do BArray fileList <- searchInfo "files" bc
return $ do fileDict@(BDict _) <- fileList
let Just (BInt l) = search [toPS "length"] fileDict
Just (BArray pth) = search [toPS "path"] fileDict
- pth' = map (\(BString s) -> fromBS s) pth
+ pth' = map (\(BString s) -> fromUtf8BS s) pth
return (pth', l)
in case (mbFpath, mbLength, mbFiles) of
(Just fpath, _, Just files) ->
@@ -347,7 +363,7 @@ pp bc =
BArray arr -> text "[" <+> (cat $ intersperse comma al) <+> text "]"
where al = map pp arr
BDict mp -> text "{" <+> cat (intersperse comma mpl) <+> text "}"
- where mpl = map (\(s, bc') -> text (fromBS s) <+> text "->" <+> pp bc') $ M.toList mp
+ where mpl = map (\(s, bc') -> text (fromUtf8BS s) <+> text "->" <+> pp bc') $ M.toList mp
prettyPrint :: BCode -> String
prettyPrint = render . pp
View
14 src/TestInstance.hs
@@ -4,13 +4,22 @@ module TestInstance
()
where
-import Data.Word
+
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
-import System.Random
+
import Test.QuickCheck
+
+{-# LANGUAGE CPP #-}
+#if MIN_VERSION_random(1,0,1)
+-- random>=1.0.1 is exporting these instances, so don't need to redefine it
+#else
+
+import Data.Word
+import System.Random
+
integralRandomR :: (Integral a, Integral b, RandomGen g, Num b) => (a, b) -> g -> (b, g)
integralRandomR (a,b) g = case randomR (c,d) g of
(x,h) -> (fromIntegral x, h)
@@ -24,6 +33,7 @@ instance Random Word32 where
instance Random Word8 where
randomR = integralRandomR
random = randomR (minBound, maxBound)
+#endif
instance Arbitrary L.ByteString where
arbitrary = L.pack `fmap` arbitrary
View
27 src/Torrent.hs
@@ -30,6 +30,7 @@ import Control.DeepSeq
import Data.Array
import Data.List
+import Data.Maybe (fromMaybe)
import qualified Data.ByteString as B
import qualified Data.Map as M
import Data.Word
@@ -37,6 +38,7 @@ import Data.Word
import Numeric
import System.Random
+import System.Random.Shuffle
import Test.QuickCheck
import Protocol.BCode
@@ -58,7 +60,8 @@ type AnnounceURL = B.ByteString
data TorrentInfo = TorrentInfo {
infoHash :: InfoHash,
pieceCount :: Int, -- Number of pieces in torrent
- announceURL :: AnnounceURL } deriving Show
+ announceURLs :: [[AnnounceURL]]
+ } deriving Show
data TorrentState = Seeding | Leeching
deriving Show
@@ -127,15 +130,19 @@ defaultPort = 1579
-- failing in the process.
mkTorrentInfo :: BCode -> IO TorrentInfo
mkTorrentInfo bc = do
- (ann, np) <- case queryInfo bc of Nothing -> fail "Could not create torrent info"
- Just x -> return x
- ih <- hashInfoDict bc
- return TorrentInfo { infoHash = ih, announceURL = ann, pieceCount = np }
- where
- queryInfo b =
- do ann <- announce b
- np <- numberPieces b
- return (ann, np)
+ (ann, np) <- case queryInfo bc of Nothing -> fail "Could not create torrent info"
+ Just x -> return x
+ ih <- hashInfoDict bc
+ let alist = fromMaybe [[ann]] $ announceList bc
+ -- BEP012 says that lists of URL inside each tier must be shuffled
+ gen <- newStdGen
+ let alist' = map (\xs -> shuffle' xs (length xs) gen) alist
+ return TorrentInfo { infoHash = ih, pieceCount = np, announceURLs = alist'}
+ where
+ queryInfo b =
+ do ann <- announce b
+ np <- numberPieces b
+ return (ann, np)
-- | Create a new PeerId for this client
mkPeerId :: StdGen -> PeerId
Something went wrong with that request. Please try again.