src/FuncTorrent/Tracker/Http.hs

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