1 {-# LANGUAGE OverloadedStrings #-}
2 module FuncTorrent.Tracker
8 import Prelude hiding (lookup, splitAt)
10 import Control.Concurrent (threadDelay)
11 import Control.Concurrent.MVar (MVar, newEmptyMVar, newMVar, readMVar, putMVar, takeMVar)
12 import Control.Monad.State
13 import Data.ByteString (ByteString)
14 import Data.ByteString.Char8 as BC (pack, unpack, splitAt)
15 import Data.Char (chr)
16 import Data.List (intercalate)
17 import Data.Map as M (lookup)
18 import Network (PortNumber)
19 import Network.HTTP.Base (urlEncode)
20 import qualified Data.ByteString.Base16 as B16 (encode)
22 import FuncTorrent.Bencode (BVal(..), decode)
23 import FuncTorrent.Metainfo (Info(..), Metainfo(..))
24 import FuncTorrent.Network (httpget)
25 import FuncTorrent.Peer (Peer(..))
26 import FuncTorrent.Utils (splitN)
29 data TrackerResponse = TrackerResponse {
32 , complete :: Maybe Integer
33 , incomplete :: Maybe Integer
36 data TrackerEventState = Started
41 data TState = TState {
42 uploaded :: MVar Integer
43 , downloaded :: MVar Integer
45 , currentState :: TrackerEventState
46 , connectedPeers :: MVar [Peer]
49 initialTrackerState :: Integer -> IO TState
50 initialTrackerState sz = do
54 return $ TState { currentState = Started
60 -- | Deserialize tracker response
61 mkTrackerResponse :: BVal -> Either ByteString TrackerResponse
62 mkTrackerResponse resp =
63 case lookup "failure reason" body of
64 Just (Bstr err) -> Left err
65 Just _ -> Left "Unknown failure"
67 let (Just (Bint i)) = lookup "interval" body
68 (Just (Bstr peersBS)) = lookup "peers" body
69 pl = map makePeer (splitN 6 peersBS)
70 in Right TrackerResponse {
74 , incomplete = Nothing
79 toInt :: String -> Integer
82 toPort :: ByteString -> Integer
83 toPort = read . ("0x" ++) . unpack . B16.encode
85 toIP :: ByteString -> String
86 toIP = Data.List.intercalate "." .
87 map (show . toInt . ("0x" ++) . unpack) .
90 makePeer :: ByteString -> Peer
91 makePeer peer = Peer "" (toIP ip') (toPort port')
92 where (ip', port') = splitAt 4 peer
94 --- | URL encode hash as per RFC1738
96 --- REVIEW: Why is this not written in terms of `Network.HTTP.Base.urlEncode` or
97 --- equivalent library function?
98 urlEncodeHash :: ByteString -> String
99 urlEncodeHash bs = concatMap (encode' . unpack) (splitN 2 bs)
100 where encode' b@[c1, c2] = let c = chr (read ("0x" ++ b))
103 escape i c1 c2 | i `elem` nonSpecialChars = [i]
104 | otherwise = "%" ++ [c1] ++ [c2]
106 nonSpecialChars = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "-_.~"
108 -- | Make arguments that should be posted to tracker.
109 -- This is a separate pure function for testability.
110 mkArgs :: PortNumber -> String -> Integer -> Integer -> Metainfo -> [(String, ByteString)]
111 mkArgs port peer_id up down m =
112 let fileSize = lengthInBytes $ info m
113 bytesLeft = fileSize - down
115 [("info_hash", pack . urlEncodeHash . B16.encode . infoHash $ m),
116 ("peer_id", pack . urlEncode $ peer_id),
117 ("port", pack $ show port),
118 ("uploaded", pack $ show up),
119 ("downloaded", pack $ show down),
120 ("left", pack $ show bytesLeft),
122 ("event", "started")]
124 trackerLoop :: PortNumber -> String -> Metainfo -> TState -> IO ByteString
125 trackerLoop port peerId m st = do
126 up <- liftIO $ readMVar $ uploaded st
127 down <- liftIO $ readMVar $ downloaded st
128 resp <- liftIO $ httpget (head . announceList $ m) $ mkArgs port peerId up down m
130 Left e -> return $ pack (show e)
132 case mkTrackerResponse trackerInfo of
135 _ <- threadDelay $ fromIntegral (interval tresp)
136 _ <- putMVar (connectedPeers st) (peers tresp)
137 trackerLoop port peerId m st