+{-# LANGUAGE OverloadedStrings #-}
module FuncTorrent.Tracker
- (connect,
- infoHash,
- prepareRequest,
- urlEncodeHash
+ (TState(..),
+ initialTrackerState,
+ trackerLoop,
) where
-import Prelude hiding (lookup)
-import Crypto.Hash.SHA1 (hash)
-import Data.ByteString.Char8 (ByteString, unpack)
+import Prelude hiding (lookup, splitAt)
+
+import System.IO (Handle)
+import Control.Applicative (liftA2)
+import Control.Concurrent (threadDelay)
+import Control.Concurrent.MVar (MVar, newEmptyMVar, newMVar, readMVar, putMVar)
+import Data.Binary (Binary(..), encode, decode)
+import Data.Binary.Put (putWord16be, putWord32be, putWord64be, putByteString)
+import Data.Binary.Get (Get, isEmpty, getByteString, getWord16be, getWord32be)
+import Data.ByteString (ByteString, hGet, hPut)
+import Data.ByteString.Char8 as BC (pack, unpack, splitAt)
+import Data.ByteString.Lazy (fromStrict, toStrict)
import Data.Char (chr)
-import Data.List (intercalate)
-import Data.Maybe (fromJust)
-import Data.Map ((!))
-import Network.HTTP (simpleHTTP, defaultGETRequest_, getResponseBody)
+import Data.List (intercalate, isPrefixOf)
+import Data.Map as M (lookup)
+import Network (PortNumber)
import Network.HTTP.Base (urlEncode)
-import Network.URI (parseURI)
import qualified Data.ByteString.Base16 as B16 (encode)
-import FuncTorrent.Bencode (InfoDict, encode)
+import FuncTorrent.Bencode (BVal(..))
+import qualified FuncTorrent.Bencode as Benc
+import FuncTorrent.Metainfo (Info(..), Metainfo(..))
+import FuncTorrent.Network (sendGetRequest)
+import FuncTorrent.Peer (Peer(..))
import FuncTorrent.Utils (splitN)
-type Url = String
--- | urlEncodeHash
---
--- >>> urlEncodeHash $ pack "123456789abcdef123456789abcdef123456789a"
--- "%124Vx%9a%bc%de%f1%23Eg%89%ab%cd%ef%124Vx%9a"
+data TrackerProtocol = Http
+ | Udp
+ | UnknownProtocol
+ deriving (Show)
+
+-- | Tracker response
+data TrackerResponse = TrackerResponse {
+ interval :: Integer
+ , peers :: [Peer]
+ , complete :: Maybe Integer
+ , incomplete :: Maybe Integer
+ } deriving (Show, Eq)
+
+data TrackerEventState = None
+ | Started
+ | Stopped
+ | Completed
+ deriving (Show, Eq)
+
+data TState = TState {
+ uploaded :: MVar Integer
+ , downloaded :: MVar Integer
+ , left :: Integer
+ , currentState :: TrackerEventState
+ , connectedPeers :: MVar [Peer]
+ }
+
+-- UDP tracker: http://bittorrent.org/beps/bep_0015.html
+data Action = Connect
+ | Announce
+ | Scrape
+ deriving (Show, Eq)
+
+type IP = String
+type Port = Integer
+
+data UDPRequest = ConnectReq Integer
+ | AnnounceReq Integer Integer ByteString String Integer Integer Integer TrackerEventState Integer
+ | ScrapeReq Integer Integer ByteString
+ deriving (Show, Eq)
+
+data UDPResponse = ConnectResp Integer Integer -- transaction_id connection_id
+ | AnnounceResp Integer Integer Integer Integer [(IP, Port)] -- transaction_id interval leechers seeders [(ip, port)]
+ | ScrapeResp Integer Integer Integer Integer
+ deriving (Show, Eq)
+
+actionToInteger :: Action -> Integer
+actionToInteger Connect = 0
+actionToInteger Announce = 1
+actionToInteger Scrape = 2
+
+intToAction :: Integer -> Action
+intToAction 0 = Connect
+intToAction 1 = Announce
+intToAction 2 = Scrape
+
+eventToInteger :: TrackerEventState -> Integer
+eventToInteger None = 0
+eventToInteger Completed = 1
+eventToInteger Started = 2
+eventToInteger Stopped = 3
+
+instance Binary UDPRequest where
+ put (ConnectReq transId) = do
+ putWord64be 0x41727101980
+ putWord32be $ fromIntegral (actionToInteger Connect)
+ putWord32be (fromIntegral transId)
+ put (AnnounceReq connId transId infohash peerId down left up event port) = do
+ putWord64be $ fromIntegral connId
+ putWord32be $ fromIntegral (actionToInteger Announce)
+ putWord32be $ fromIntegral transId
+ putByteString infohash
+ putByteString (BC.pack peerId)
+ putWord64be (fromIntegral down)
+ putWord64be (fromIntegral left)
+ putWord64be (fromIntegral up)
+ putWord32be $ fromIntegral (eventToInteger None)
+ putWord32be 0
+ -- key is optional, we will not send it for now
+ putWord32be $ fromIntegral (-1)
+ putWord16be $ fromIntegral port
+ put (ScrapeReq _ _ _) = undefined
+ get = undefined
+
+instance Binary UDPResponse where
+ put = undefined
+ get = do
+ a <- getWord32be -- action
+ case a of
+ 0 -> liftA2 ConnectResp (fromIntegral <$> getWord32be) (fromIntegral <$> getWord32be)
+ 1 -> do
+ tid <- fromIntegral <$> getWord32be
+ interval' <- fromIntegral <$> getWord32be
+ _ <- getWord32be -- leechers
+ _ <- getWord32be -- seeders
+ ipportpairs <- getIPPortPairs -- [(ip, port)]
+ return $ AnnounceResp tid interval' 0 0 ipportpairs
+ 2 -> do
+ tid <- fromIntegral <$> getWord32be
+ _ <- getWord32be
+ _ <- getWord32be
+ _ <- getWord32be
+ return $ ScrapeResp tid 0 0 0
+ _ -> error ("unknown response action type: " ++ show a)
+
+getIPPortPairs :: Get [(IP, Port)]
+getIPPortPairs = do
+ empty <- isEmpty
+ if empty
+ then return []
+ else do
+ ip <- toIP <$> getByteString 6
+ port <- toPort <$> getByteString 2
+ ipportpairs <- getIPPortPairs
+ return $ (ip, port) : ipportpairs
+
+initialTrackerState :: Integer -> IO TState
+initialTrackerState sz = do
+ ps <- newEmptyMVar
+ up <- newMVar 0
+ down <- newMVar 0
+ return $ TState { currentState = None
+ , connectedPeers = ps
+ , uploaded = up
+ , downloaded = down
+ , left = sz }
+
+-- | Deserialize HTTP tracker response
+parseTrackerResponse :: BVal -> Either ByteString TrackerResponse
+parseTrackerResponse resp =
+ case lookup "failure reason" body of
+ Just (Bstr err) -> Left err
+ Just _ -> Left "Unknown failure"
+ Nothing ->
+ let (Just (Bint i)) = lookup "interval" body
+ (Just (Bstr peersBS)) = lookup "peers" body
+ pl = map makePeer (splitN 6 peersBS)
+ in Right TrackerResponse {
+ interval = i
+ , peers = pl
+ , complete = Nothing
+ , incomplete = Nothing
+ }
+ where
+ (Bdict body) = resp
+
+toInt :: String -> Integer
+toInt = read
+
+makePeer :: ByteString -> Peer
+makePeer peer = Peer "" (toIP ip') (toPort port')
+ where (ip', port') = splitAt 4 peer
+
+toPort :: ByteString -> Port
+toPort = read . ("0x" ++) . unpack . B16.encode
+
+toIP :: ByteString -> IP
+toIP = Data.List.intercalate "." .
+ map (show . toInt . ("0x" ++) . unpack) .
+ splitN 2 . B16.encode
+
+--- | URL encode hash as per RFC1738
+--- TODO: Add tests
+--- REVIEW: Why is this not written in terms of `Network.HTTP.Base.urlEncode` or
+--- equivalent library function?
urlEncodeHash :: ByteString -> String
urlEncodeHash bs = concatMap (encode' . unpack) (splitN 2 bs)
where encode' b@[c1, c2] = let c = chr (read ("0x" ++ b))
nonSpecialChars = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "-_.~"
-infoHash :: InfoDict -> ByteString
-infoHash m = hash . encode $ (m ! "info")
-
-prepareRequest :: InfoDict -> String -> Integer -> String
-prepareRequest d peer_id len =
- let p = [("info_hash", urlEncodeHash ((B16.encode . infoHash) d)),
- ("peer_id", urlEncode peer_id),
- ("port", "6881"),
- ("uploaded", "0"),
- ("downloaded", "0"),
- ("left", show len),
- ("compact", "1"),
- ("event", "started")]
- in intercalate "&" [f ++ "=" ++ s | (f,s) <- p]
-
-connect :: Url -> String -> IO ByteString
-connect baseurl qstr = simpleHTTP (defaultGETRequest_ url) >>= getResponseBody
- where url = fromJust . parseURI $ (baseurl ++ "?" ++ qstr)
+-- | Make arguments that should be posted to tracker.
+-- This is a separate pure function for testability.
+mkArgs :: PortNumber -> String -> Integer -> Integer -> Metainfo -> [(String, ByteString)]
+mkArgs port peer_id up down m =
+ let fileSize = lengthInBytes $ info m
+ bytesLeft = fileSize - down
+ in
+ [("info_hash", pack . urlEncodeHash . B16.encode . infoHash $ m),
+ ("peer_id", pack . urlEncode $ peer_id),
+ ("port", pack $ show port),
+ ("uploaded", pack $ show up),
+ ("downloaded", pack $ show down),
+ ("left", pack $ show bytesLeft),
+ ("compact", "1"),
+ ("event", "started")]
+
+trackerLoop :: PortNumber -> String -> Metainfo -> TState -> IO ByteString
+trackerLoop port peerId m st = do
+ up <- readMVar $ uploaded st
+ down <- readMVar $ downloaded st
+ resp <- sendGetRequest (head . announceList $ m) $ mkArgs port peerId up down m
+ case Benc.decode resp of
+ Left e -> return $ pack (show e)
+ Right trackerInfo ->
+ case parseTrackerResponse trackerInfo of
+ Left e -> return e
+ Right tresp -> do
+ _ <- threadDelay $ fromIntegral (interval tresp)
+ _ <- putMVar (connectedPeers st) (peers tresp)
+ trackerLoop port peerId m st
+
+-- udp tracker
+getResponse :: Handle -> IO UDPResponse
+getResponse h = do
+ -- connect packet is 16 bytes long
+ -- announce packet is atleast 20 bytes long
+ bs <- hGet h (16*1024)
+ return $ decode $ fromStrict bs
+
+sendRequest :: Handle -> UDPRequest -> IO ()
+sendRequest h req = hPut h bsReq
+ where bsReq = toStrict $ encode req
+
+getTrackerType :: String -> TrackerProtocol
+getTrackerType url | isPrefixOf "http://" url = Http
+ | isPrefixOf "udp://" url = Udp
+ | otherwise = UnknownProtocol
projects / functorrent.git / blobdiff