Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP

Loading…

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

Merged
merged 4 commits into from

2 participants

Nikolay Mikov Jesper Louis Andersen
Nikolay Mikov

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)

Jesper Louis Andersen jlouis merged commit 7874f79 into from
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
Commits on Apr 21, 2012
  1. Nikolay Mikov
Commits on May 6, 2012
  1. Nikolay Mikov

    fixes #3

    nikmikov authored
Commits on May 7, 2012
  1. Nikolay Mikov
Commits on May 12, 2012
  1. Nikolay Mikov
This page is out of date. Refresh to see the latest.
5 Combinatorrent.cabal
View
@@ -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
1  src/Channels.hs
View
@@ -1,4 +1,5 @@
{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
module Channels
( Peer(..)
, PeerChokeMsg(..)
7 src/Digest.hs
View
@@ -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
2  src/Process/Peer.hs
View
@@ -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
103 src/Process/Tracker.hs
View
@@ -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
22 src/Protocol/BCode.hs
View
@@ -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
14 src/TestInstance.hs
View
@@ -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
27 src/Torrent.hs
View
@@ -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.