src/FuncTorrent/Tracker.hs

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