src/FuncTorrent/Tracker.hs

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