src/FuncTorrent/Tracker.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 module FuncTorrent.Tracker
  22        (runTracker
  23        , getConnectedPeers
  24        , newTracker
  25        ) where
  26
  27 import Control.Concurrent(forkIO)
  28 import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)
  29 import Control.Concurrent.MVar (newEmptyMVar, putMVar, readMVar)
  30 import Control.Monad.State (StateT, liftIO, get, runStateT)
  31 import Control.Monad (forever)
  32 import Data.ByteString.Char8 (ByteString, pack, unpack)
  33 import Data.List (isPrefixOf)
  34 import Network (PortNumber)
  35
  36 import qualified FuncTorrent.Tracker.Http as HT (trackerLoop)
  37 import qualified FuncTorrent.Tracker.Udp as UT (trackerLoop)
  38 import FuncTorrent.Tracker.Types (TState(..), TrackerEventState(..), TrackerProtocol(..), TrackerMsg(..))
  39 import FuncTorrent.Utils (Port, toPort)
  40 import qualified FuncTorrent.FileSystem as FS (MsgChannel)
  41 import FuncTorrent.Peer (Peer)
  42
  43 type MsgChannel = Chan TrackerMsg
  44
  45 data TrackerUrl = TrackerUrl { protocol :: TrackerProtocol
  46                              , host :: String
  47                              , port :: Port
  48                              , path :: String
  49                              }
  50
  51 newTracker :: IO MsgChannel
  52 newTracker = newChan
  53
  54 parseUrl :: String -> TrackerUrl
  55 parseUrl url = TrackerUrl proto host port path
  56   where proto = getTrackerType url
  57         host = getHostname url
  58         port = getPort url
  59         path = getPath url
  60
  61 getHostname :: String -> String
  62 getHostname url = takeWhile (/= ':') $ drop 2 $ dropWhile (/= '/') url
  63
  64 getPort :: String -> Port
  65 getPort url = toPort . pack $ takeWhile (/= '/') $ drop 1 $ dropWhile (/= ':') $ drop 2 $ dropWhile (/= '/') url
  66
  67 getPath :: String -> String
  68 getPath url = dropWhile (/= '/') $ dropWhile (/= ':') $ drop 1 $ dropWhile (/= ':') url
  69
  70 runTracker :: MsgChannel -> FS.MsgChannel -> ByteString -> PortNumber
  71            -> String -> [String] -> Integer -> IO ()
  72 runTracker msgChannel fsChan infohash port peerId announceList sz = do
  73   ps <- newEmptyMVar
  74   let initialTState = TState { currentState = None
  75                              , connectedPeers = ps
  76                              , left = sz }
  77       turl = head announceList
  78       host = getHostname turl
  79   case getTrackerType turl of
  80     Http -> do
  81       _ <- forkIO $ HT.trackerLoop host port peerId infohash fsChan initialTState
  82       runStateT (msgHandler msgChannel) initialTState
  83       return ()
  84     Udp -> do
  85       _ <- forkIO $ UT.trackerLoop host (fromIntegral port) peerId infohash fsChan initialTState
  86       return ()
  87     _ ->
  88       error "Tracker Protocol unimplemented"
  89
  90 getTrackerType :: String -> TrackerProtocol
  91 getTrackerType url | "http://" `isPrefixOf` url = Http
  92                    | "udp://" `isPrefixOf` url  = Udp
  93                    | otherwise                = UnknownProtocol
  94
  95
  96 msgHandler :: MsgChannel -> StateT TState IO ()
  97 msgHandler c = forever $ do
  98   st <- get
  99   peers <- liftIO $ readMVar (connectedPeers st)
 100   msg <- liftIO recvMsg
 101   liftIO $ sendResponse msg peers
 102     where
 103       recvMsg = readChan c
 104       sendResponse msg peers =
 105         case msg of
 106           GetConnectedPeersMsg var ->
 107             putMVar var peers
 108           _ ->
 109             putStrLn "Unhandled Tracker Msg"
 110
 111 getConnectedPeers :: MsgChannel -> IO [Peer]
 112 getConnectedPeers c = do
 113   v <- newEmptyMVar
 114   writeChan c (GetConnectedPeersMsg v)
 115   readMVar v