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, 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)
  21
  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)
  27
  28 -- | Tracker response
  29 data TrackerResponse = TrackerResponse {
  30   interval :: Integer
  31   , peers :: [Peer]
  32   , complete :: Maybe Integer
  33   , incomplete :: Maybe Integer
  34   } deriving (Show, Eq)
  35
  36 data TrackerEventState = Started
  37                        | Stopped
  38                        | Completed
  39                        deriving (Show, Eq)
  40
  41 data TState = TState {
  42     uploaded :: MVar Integer
  43   , downloaded :: MVar Integer
  44   , left :: Integer
  45   , currentState :: TrackerEventState
  46   , connectedPeers :: MVar [Peer]
  47   }
  48
  49 initialTrackerState :: Integer -> IO TState
  50 initialTrackerState sz = do
  51   ps <- newEmptyMVar
  52   up <- newMVar 0
  53   down <- newMVar 0
  54   return $ TState { currentState = Started
  55                   , connectedPeers = ps
  56                   , uploaded = up
  57                   , downloaded = down
  58                   , left = sz }
  59
  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"
  66       Nothing ->
  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 {
  71                    interval = i
  72                  , peers = pl
  73                  , complete = Nothing
  74                  , incomplete = Nothing
  75                  }
  76     where
  77       (Bdict body) = resp
  78
  79       toInt :: String -> Integer
  80       toInt = read
  81
  82       toPort :: ByteString -> Integer
  83       toPort = read . ("0x" ++) . unpack . B16.encode
  84
  85       toIP :: ByteString -> String
  86       toIP = Data.List.intercalate "." .
  87              map (show . toInt . ("0x" ++) . unpack) .
  88                  splitN 2 . B16.encode
  89
  90       makePeer :: ByteString -> Peer
  91       makePeer peer = Peer "" (toIP ip') (toPort port')
  92           where (ip', port') = splitAt 4 peer
  93
  94 --- | URL encode hash as per RFC1738
  95 --- TODO: Add tests
  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))
 101                             in escape c c1 c2
 102         encode' _ = ""
 103         escape i c1 c2 | i `elem` nonSpecialChars = [i]
 104                        | otherwise = "%" ++ [c1] ++ [c2]
 105
 106         nonSpecialChars = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "-_.~"
 107
 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
 114   in
 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),
 121      ("compact", "1"),
 122      ("event", "started")]
 123
 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
 129   case decode resp of
 130     Left e -> return $ pack (show e)
 131     Right trackerInfo ->
 132       case mkTrackerResponse trackerInfo of
 133         Left e -> return e
 134         Right tresp -> do
 135           _ <- threadDelay $ fromIntegral (interval tresp)
 136           _ <- putMVar (connectedPeers st) (peers tresp)
 137           trackerLoop port peerId m st
 138