From e7914d0fad7d5ef26f0c89e8b78b5c7b6a2868f5 Mon Sep 17 00:00:00 2001 From: Sam T Date: Fri, 26 Apr 2013 00:18:53 +0400 Subject: ~ Starting separating protocol and high level api. It will be more convenient to provide high level api and raw protocol separated. In many use cases we don't worry about protocol but need some simple things like track swarm/peer state. So I think it will be better to refactor library in the following way: 1. Network.BitTorrent.Tracker.Protocol, Network.BitTorrent.PeerWire.Protocol For raw protocol definitions, documentation and serialization. 2. Network.BitTorrent.Tracker Network.BitTorrent.PeerWire For convenient API. Though we should not restrict user to in some particular way, so high level api should be flexible enough. In other words: mechanism, not policy/framework. --- src/Network/BitTorrent/Tracker.hs | 271 +++++++++-------------------- src/Network/BitTorrent/Tracker/Protocol.hs | 204 ++++++++++++++++++++++ 2 files changed, 288 insertions(+), 187 deletions(-) create mode 100644 src/Network/BitTorrent/Tracker/Protocol.hs (limited to 'src/Network/BitTorrent') diff --git a/src/Network/BitTorrent/Tracker.hs b/src/Network/BitTorrent/Tracker.hs index 99ffc280..6ecf4fc2 100644 --- a/src/Network/BitTorrent/Tracker.hs +++ b/src/Network/BitTorrent/Tracker.hs @@ -1,4 +1,3 @@ --- TODO: add "compact" field to TRequest -- | -- Copyright : (c) Sam T. 2013 -- License : MIT @@ -6,195 +5,57 @@ -- Stability : experimental -- Portability : non-portable -- -{-# OPTIONS -fno-warn-orphans #-} -{-# LANGUAGE OverloadedStrings #-} --- make higher level api +-- This module provides high level API for peer->tracker +-- communication. +-- module Network.BitTorrent.Tracker ( module Network.BitTorrent.Tracker.Scrape - , Progress(..), TSession(..) - , tsession, startProgress - -- * Requests - , Event(..), TRequest(..) - , startedReq, regularReq, stoppedReq, completedReq + , withTracker, completedReq + + -- * Progress + , Progress(..), startProgress - -- * Responses - , TResponse(..) - , sendRequest + -- * Connection + , TConnection(..), tconnection - -- * Defaults - , defaultPorts, defaultNumWant - ) - where + -- * Session + , TSession, getPeerList, getProgress, waitInterval + + -- * Re-export + , defaultPorts + ) 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 Control.Concurrent +import Control.Concurrent.STM +import Control.Exception +import Control.Monad +import Data.IORef import Data.Torrent - import Network -import Network.Socket -import Network.HTTP import Network.URI import Network.BitTorrent.Peer import Network.BitTorrent.PeerID +import Network.BitTorrent.Tracker.Protocol import Network.BitTorrent.Tracker.Scrape -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 :: InfoHash -- ^ 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 :: Integer -- ^ # of bytes that the peer has uploaded in the swarm. - , reqDownloaded :: Integer -- ^ # of bytes downloaded in the swarm by the peer. - , reqLeft :: Integer -- ^ # 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 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 - `addHashToURI` reqInfoHash req - - --- | Ports typically reserved for bittorrent. -defaultPorts :: [PortNumber] -defaultPorts = [6881..6889] - --- | Above 25, new peers are highly unlikely to increase download speed. --- Even 30 peers is _plenty_, the official client version 3 in fact only --- actively forms new connections if it has less than 30 peers and will --- refuse connections if it has 55. So default value is set to 25. --- -defaultNumWant :: Int -defaultNumWant = 25 - - --- | 'TSession' (shorthand for Tracker session) combines tracker request +-- | 'TConnection' (shorthand for Tracker session) combines tracker request -- fields neccessary for tracker, torrent and client identification. -- -- This data is considered as static within one session. -- -data TSession = TSession { - tsesAnnounce :: URI -- ^ Announce URL. - , tsesInfoHash :: InfoHash -- ^ Hash of info part of current .torrent file. - , tsesPeerID :: PeerID -- ^ Client peer ID. - , tsesPort :: PortNumber -- ^ The port number the client is listenning on. +data TConnection = TConnection { + tconnAnnounce :: URI -- ^ Announce URL. + , tconnInfoHash :: InfoHash -- ^ Hash of info part of current .torrent file. + , tconnPeerID :: PeerID -- ^ Client peer ID. + , tconnPort :: PortNumber -- ^ The port number the client is listenning on. } deriving Show -tsession :: Torrent -> PeerID -> PortNumber -> TSession -tsession t = TSession (tAnnounce t) (tInfoHash t) +tconnection :: Torrent -> PeerID -> PortNumber -> TConnection +tconnection t = TConnection (tAnnounce t) (tInfoHash t) -- | 'Progress' contains upload/download/left stats about @@ -213,12 +74,12 @@ startProgress = Progress 0 0 -- | used to avoid boilerplate; do NOT export me -genericReq :: TSession -> Progress -> TRequest +genericReq :: TConnection -> Progress -> TRequest genericReq ses pr = TRequest { - reqAnnounce = tsesAnnounce ses - , reqInfoHash = tsesInfoHash ses - , reqPeerID = tsesPeerID ses - , reqPort = tsesPort ses + reqAnnounce = tconnAnnounce ses + , reqInfoHash = tconnInfoHash ses + , reqPeerID = tconnPeerID ses + , reqPort = tconnPort ses , reqUploaded = prUploaded pr , reqDownloaded = prDownloaded pr @@ -233,7 +94,7 @@ genericReq ses pr = TRequest { -- | The first request to the tracker that should be created is 'startedReq'. -- It includes necessary 'Started' event field. -- -startedReq :: TSession -> Progress -> TRequest +startedReq :: TConnection -> Progress -> TRequest startedReq ses pr = (genericReq ses pr) { reqIP = Nothing , reqNumWant = Just defaultNumWant @@ -244,7 +105,7 @@ startedReq ses pr = (genericReq ses pr) { -- notify tracker about current state of the client -- so new peers could connect to the client. -- -regularReq :: Int -> TSession -> Progress -> TRequest +regularReq :: Int -> TConnection -> Progress -> TRequest regularReq numWant ses pr = (genericReq ses pr) { reqIP = Nothing , reqNumWant = Just numWant @@ -253,7 +114,7 @@ regularReq numWant ses pr = (genericReq ses pr) { -- | Must be sent to the tracker if the client is shutting down gracefully. -- -stoppedReq :: TSession -> Progress -> TRequest +stoppedReq :: TConnection -> Progress -> TRequest stoppedReq ses pr = (genericReq ses pr) { reqIP = Nothing , reqNumWant = Nothing @@ -263,7 +124,7 @@ stoppedReq ses pr = (genericReq ses pr) { -- | Must be sent to the tracker when the download completes. -- However, must not be sent if the download was already 100% complete. -- -completedReq :: TSession -> Progress -> TRequest +completedReq :: TConnection -> Progress -> TRequest completedReq ses pr = (genericReq ses pr) { reqIP = Nothing , reqNumWant = Nothing @@ -271,16 +132,52 @@ completedReq ses pr = (genericReq ses pr) { } --- | TODO rename to ask for peers --- -sendRequest :: TRequest -> IO (Result TResponse) -sendRequest req = do - let r = mkHTTPRequest (encodeRequest req) - rawResp <- simpleHTTP r - respBody <- getResponseBody rawResp - return (decoded (BC.pack respBody)) +data TSession = TSession { + seProgress :: TVar Progress + , seInterval :: IORef Int + , sePeers :: TVar [Peer] + } + +newSession :: Progress -> Int -> [Peer] -> IO TSession +newSession pr i ps = TSession <$> newTVarIO pr <*> newIORef i <*> newTVarIO ps + +getPeerList :: TSession -> IO [Peer] +getPeerList = readTVarIO . sePeers + +getProgress :: TSession -> IO Progress +getProgress = readTVarIO . seProgress + +waitInterval :: TSession -> IO () +waitInterval = readIORef . seInterval >=> threadDelay + +withTracker :: Progress -> TConnection -> (TSession -> IO a) -> IO a +withTracker initProgress conn action = bracket start end (action . fst) where - mkHTTPRequest :: URI -> Request String - mkHTTPRequest uri = Request uri GET [] "" + start = do + res <- sendRequest (startedReq conn initProgress) + case res of + Left err -> ioError (userError err) + Right (Failure err) -> ioError (userError (show err)) + Right resp -> do + se <- newSession initProgress (respInterval resp) (respPeers resp) + tid <- forkIO (syncSession se) + return (se, tid) + + + syncSession se = do + waitInterval se + pr <- getProgress se + eresp <- sendRequest (regularReq defaultNumWant conn pr) + case eresp of + Right (OK { respInterval = i, respPeers = ps }) -> do + writeIORef (seInterval se) i + atomically $ writeTVar (sePeers se) ps + _ -> return () + syncSession se + + + end (se, tid) = do + killThread tid + getProgress se >>= sendRequest . stoppedReq conn diff --git a/src/Network/BitTorrent/Tracker/Protocol.hs b/src/Network/BitTorrent/Tracker/Protocol.hs new file mode 100644 index 00000000..000b38c1 --- /dev/null +++ b/src/Network/BitTorrent/Tracker/Protocol.hs @@ -0,0 +1,204 @@ +-- | +-- Copyright : (c) Sam T. 2013 +-- License : MIT +-- Maintainer : pxqr.sta@gmail.com +-- Stability : experimental +-- Portability : non-portable +-- +-- +-- This module provides straigthforward Tracker protocol +-- implementation. The tracker is an HTTP/HTTPS service: +-- +-- * A tracker request is HTTP GET request; used to include +-- metrics from clients that help the tracker keep overall +-- statistics about the torrent. +-- +-- * The tracker response includes a peer list that helps the +-- client participate in the torrent. +-- +-- For more convenient high level API see Network.BitTorrent.Tracker +-- module. +-- +{-# OPTIONS -fno-warn-orphans #-} +{-# LANGUAGE OverloadedStrings #-} +-- TODO: add "compact" field to TRequest +module Network.BitTorrent.Tracker.Protocol + ( module Network.BitTorrent.Tracker.Scrape + + , Event(..), TRequest(..), TResponse(..) + , sendRequest + + -- * Defaults + , defaultPorts, defaultNumWant + ) + 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 Data.Torrent + +import Network +import Network.Socket +import Network.HTTP +import Network.URI + +import Network.BitTorrent.Peer +import Network.BitTorrent.PeerID +import Network.BitTorrent.Tracker.Scrape + + +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 :: InfoHash -- ^ 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 :: Integer -- ^ # of bytes that the peer has uploaded in the swarm. + , reqDownloaded :: Integer -- ^ # of bytes downloaded in the swarm by the peer. + , reqLeft :: Integer -- ^ # 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 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 + `addHashToURI` reqInfoHash req + + +-- | Ports typically reserved for bittorrent. +defaultPorts :: [PortNumber] +defaultPorts = [6881..6889] + +-- | Above 25, new peers are highly unlikely to increase download speed. +-- Even 30 peers is _plenty_, the official client version 3 in fact only +-- actively forms new connections if it has less than 30 peers and will +-- refuse connections if it has 55. So default value is set to 25. +-- +defaultNumWant :: Int +defaultNumWant = 25 + + + + +-- | TODO rename to ask for peers +-- +sendRequest :: TRequest -> IO (Result TResponse) +sendRequest req = do + let r = mkHTTPRequest (encodeRequest req) + + rawResp <- simpleHTTP r + respBody <- getResponseBody rawResp + return (decoded (BC.pack respBody)) + + where + mkHTTPRequest :: URI -> Request String + mkHTTPRequest uri = Request uri GET [] "" -- cgit v1.2.3