src/Tracker.hs

   1 module Tracker where
   2
   3 import Prelude hiding (lookup)
   4
   5 import Bencode (BVal(..), InfoDict, encode)
   6 import Crypto.Hash.SHA1 (hash)
   7 import Data.ByteString.Char8 (ByteString, pack, unpack)
   8 import Data.Char (chr)
   9 import Data.List (intercalate)
  10 import Data.Map as M (Map, (!))
  11 import Network.HTTP (simpleHTTP, getRequest, getResponseBody)
  12 import Network.HTTP.Base (urlEncode)
  13 import Utils (splitN)
  14 import qualified Data.ByteString.Base16 as B16 (encode)
  15
  16 type Url = String
  17
  18 -- | urlEncodeHash
  19 --
  20 -- >>> urlEncodeHash $ pack "123456789abcdef123456789abcdef123456789a"
  21 -- "%124Vx%9a%bc%de%f1%23Eg%89%ab%cd%ef%124Vx%9a"
  22 urlEncodeHash :: ByteString -> String
  23 urlEncodeHash bs = concatMap (encode' . unpack) (splitN 2 bs)
  24   where encode' b@[c1, c2] = let c =  chr (read ("0x" ++ b))
  25                             in escape c c1 c2
  26         encode' _ = ""
  27         escape i c1 c2 | i `elem` nonSpecialChars = [i]
  28                        | otherwise = "%" ++ [c1] ++ [c2]
  29
  30         nonSpecialChars = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "-_.~"
  31
  32 infoHash :: Map BVal BVal -> ByteString
  33 infoHash m = let info = m ! Bstr (pack "info")
  34              in (hash . pack . encode) info
  35
  36 prepareRequest :: InfoDict -> String -> Integer -> String
  37 prepareRequest d peer_id len =
  38   let p = [("info_hash", urlEncodeHash ((B16.encode . infoHash) d)),
  39            ("peer_id", urlEncode peer_id),
  40            ("port", "6881"),
  41            ("uploaded", "0"),
  42            ("downloaded", "0"),
  43            ("left", show len),
  44            ("compact", "1"),
  45            ("event", "started")]
  46   in intercalate "&" [f ++ "=" ++ s | (f,s) <- p]
  47
  48 connect :: Url -> String -> IO String
  49 connect baseurl qstr = let url = baseurl ++ "?" ++ qstr
  50                        in simpleHTTP (getRequest url) >>=
  51                           getResponseBody