src/FuncTorrent/Tracker/Http.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2 {-
   3 Copyright (C) 2015-2016 Ramakrishnan Muthukrishnan <ram@rkrishnan.org>
   4
   5 This file is part of FuncTorrent.
   6
   7 FuncTorrent is free software; you can redistribute it and/or modify
   8 it under the terms of the GNU General Public License as published by
   9 the Free Software Foundation; either version 3 of the License, or
  10 (at your option) any later version.
  11
  12 FuncTorrent is distributed in the hope that it will be useful,
  13 but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 GNU General Public License for more details.
  16
  17 You should have received a copy of the GNU General Public License
  18 along with FuncTorrent; if not,  see <http://www.gnu.org/licenses/>
  19 -}
  20
  21 module FuncTorrent.Tracker.Http
  22        (trackerLoop
  23        ) where
  24
  25 import Prelude hiding (lookup, splitAt)
  26
  27 import Control.Concurrent (threadDelay)
  28 import Control.Concurrent.MVar (readMVar, putMVar)
  29 import Control.Monad (forever)
  30 import qualified Data.ByteString.Base16 as B16 (encode)
  31 import Data.ByteString (ByteString)
  32 import Data.ByteString.Char8 as BC (pack, unpack, splitAt)
  33 import Data.Char (chr)
  34 import Data.List (intercalate)
  35 import Data.Map as M (lookup)
  36 import Network (PortNumber)
  37 import Network.HTTP.Base (urlEncode)
  38
  39 import qualified FuncTorrent.Bencode as Benc
  40 import FuncTorrent.Bencode (BVal(..))
  41 import qualified FuncTorrent.FileSystem as FS (MsgChannel, Stats(..), getStats)
  42 import FuncTorrent.Network (sendGetRequest)
  43 import FuncTorrent.Peer (Peer(..))
  44 import FuncTorrent.Utils (splitN)
  45 import FuncTorrent.Tracker.Types(TState(..), TrackerResponse(..), Port, IP)
  46
  47
  48 --- | URL encode hash as per RFC1738
  49 --- TODO: Add tests
  50 --- REVIEW: Why is this not written in terms of `Network.HTTP.Base.urlEncode` or
  51 --- equivalent library function?
  52 urlEncodeHash :: ByteString -> String
  53 urlEncodeHash bs = concatMap (encode' . unpack) (splitN 2 bs)
  54   where encode' b@[c1, c2] = let c =  chr (read ("0x" ++ b))
  55                             in escape c c1 c2
  56         encode' _ = ""
  57         escape i c1 c2 | i `elem` nonSpecialChars = [i]
  58                        | otherwise = "%" ++ [c1] ++ [c2]
  59
  60         nonSpecialChars = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "-_.~"
  61
  62 -- | Make arguments that should be posted to tracker.
  63 -- This is a separate pure function for testability.
  64 mkArgs :: PortNumber -> String -> Integer -> Integer -> Integer -> ByteString -> [(String, ByteString)]
  65 mkArgs port peer_id up down left' infoHash =
  66   [("info_hash", pack . urlEncodeHash . B16.encode $ infoHash),
  67    ("peer_id", pack . urlEncode $ peer_id),
  68    ("port", pack $ show port),
  69    ("uploaded", pack $ show up),
  70    ("downloaded", pack $ show down),
  71    ("left", pack $ show left'),
  72    ("compact", "1"),
  73    ("event", "started")]
  74
  75 trackerLoop :: String -> PortNumber -> String -> ByteString -> FS.MsgChannel -> TState -> IO ()
  76 trackerLoop url port peerId infohash fschan tstate = forever $ do
  77   st' <- FS.getStats fschan
  78   st <- readMVar st'
  79   let up = FS.bytesRead st
  80       down = FS.bytesWritten st
  81   resp <- sendGetRequest url $ mkArgs port peerId up down (left tstate) infohash
  82   case Benc.decode resp of
  83     Left e -> return () -- $ pack (show e)
  84     Right trackerInfo ->
  85       case parseTrackerResponse trackerInfo of
  86         Left e -> return () -- e
  87         Right tresp -> do
  88           _ <- threadDelay $ fromIntegral (interval tresp)
  89           _ <- putMVar (connectedPeers tstate) (peers tresp)
  90           return () -- trackerLoop port peerId st
  91
  92 parseTrackerResponse :: BVal -> Either ByteString TrackerResponse
  93 parseTrackerResponse resp =
  94     case lookup "failure reason" body of
  95       Just (Bstr err) -> Left err
  96       Just _ -> Left "Unknown failure"
  97       Nothing ->
  98           let (Just (Bint i)) = lookup "interval" body
  99               (Just (Bstr peersBS)) = lookup "peers" body
 100               pl = map makePeer (splitN 6 peersBS)
 101           in Right TrackerResponse {
 102                    interval = i
 103                  , peers = pl
 104                  , complete = Nothing
 105                  , incomplete = Nothing
 106                  }
 107     where
 108       (Bdict body) = resp
 109
 110 makePeer :: ByteString -> Peer
 111 makePeer peer = Peer "" (toIP ip') (toPort port')
 112   where (ip', port') = splitAt 4 peer
 113
 114 toPort :: ByteString -> Port
 115 toPort = read . ("0x" ++) . unpack . B16.encode
 116
 117 toIP :: ByteString -> IP
 118 toIP = Data.List.intercalate "." .
 119        map (show . toInt . ("0x" ++) . unpack) .
 120        splitN 2 . B16.encode
 121
 122 toInt :: String -> Integer
 123 toInt = read