From 5233bacca87058537323ac71748cb626f30dec54 Mon Sep 17 00:00:00 2001 From: Sam T Date: Fri, 5 Apr 2013 01:57:15 +0400 Subject: + add THP --- src/Network/Torrent/THP.hs | 205 +++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 205 insertions(+) create mode 100644 src/Network/Torrent/THP.hs (limited to 'src/Network/Torrent') diff --git a/src/Network/Torrent/THP.hs b/src/Network/Torrent/THP.hs new file mode 100644 index 00000000..e440d0f2 --- /dev/null +++ b/src/Network/Torrent/THP.hs @@ -0,0 +1,205 @@ +{-# OPTIONS -fno-warn-orphans #-} +{-# LANGUAGE OverloadedStrings #-} +module Network.Torrent.THP + ( Peer(..), Event(..), TRequest(..), TResponse(..) + , sendRequest, defaultRequest + ) + where + +import Control.Applicative +import Data.Maybe +import Data.BEncode +import Data.Char as Char +import Data.Monoid +import Data.List as L +import Data.Map as M +import Data.ByteString as B +import qualified Data.ByteString.Lazy as Lazy +import Data.ByteString.Char8 as BC +import qualified Data.ByteString.Builder as B +import qualified Data.ByteString.Builder.Prim as BP +import Data.Text as T +import Data.Serialize.Get hiding (Result) +import Data.URLEncoded as URL + +import Network +import Network.HTTP +import Network.URI +import Network.Torrent.PeerID + +import Numeric + +type IP = Int +type Hash = ByteString + +data Peer = Peer { + peerID :: Maybe PeerID + , peerIP :: IP + , peerPort :: PortNumber + } deriving Show + +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 :: Hash -- ^ 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 :: Int -- ^ # of bytes that the peer has uploaded in the swarm. + , reqDownloaded :: Int -- ^ # of bytes downloaded in the swarm by the peer. + , reqLeft :: Int -- ^ # of bytes needed in order to complete download. + , reqIP :: Maybe IP -- ^ 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 PeerID where + urlShow = BC.unpack . getPeerID + +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 + `addHash` BC.unpack (reqInfoHash req) + where + addHash :: URI -> String -> URI + addHash uri s = uri { uriQuery = uriQuery uri ++ "&info_hash=" ++ rfc1738Encode s } + + rfc1738Encode :: String -> String + rfc1738Encode = L.concatMap (\c -> if unreserved c then [c] else encode c) + where + unreserved = (`L.elem` chars) + chars = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_./" + encode :: Char -> String + encode c = '%' : pHex c + pHex c = + let p = (showHex . ord $ c) "" + in if L.length p == 1 then '0' : p else p + + +-- | Ports typically reserved for bittorrent. +defaultPorts :: [PortNumber] +defaultPorts = [6881..6889] + +defaultRequest :: URI -> Hash -> PeerID -> TRequest +defaultRequest announce hash pid = + TRequest { + reqAnnounce = announce + , reqInfoHash = hash + , reqPeerID = pid + , reqPort = L.head defaultPorts + , reqUploaded = 0 + , reqDownloaded = 0 + , reqLeft = 0 + , reqIP = Nothing + , reqNumWant = Just 50 + , reqEvent = Just Started + } + + +-- | TODO rename to ask for peers +-- +sendRequest :: TRequest -> IO (Result TResponse) +sendRequest req = do + let r = mkHTTPRequest (encodeRequest req) + print r + + rawResp <- simpleHTTP r + respBody <- getResponseBody rawResp + print respBody + return (decoded (BC.pack respBody)) + + where + mkHTTPRequest :: URI -> Request String + mkHTTPRequest uri = Request uri GET [] "" -- cgit v1.2.3