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 getTrackerType :: String -> TrackerProtocol
  62 getTrackerType url | isPrefixOf "http://" url = Http
  63                    | isPrefixOf "udp://" url  = Udp
  64                    | otherwise                = UnknownProtocol
  65
  66 getHostname :: String -> String
  67 getHostname url = takeWhile (/= ':') $ drop 2 $ dropWhile (/= '/') url
  68
  69 getPort :: String -> Port
  70 getPort url = toPort . pack $ takeWhile (/= '/') $ drop 1 $ dropWhile (/= ':') $ drop 2 $ dropWhile (/= '/') url
  71
  72 getPath :: String -> String
  73 getPath url = dropWhile (/= '/') $ dropWhile (/= ':') $ drop 1 $ dropWhile (/= ':') url
  74
  75 runTracker :: MsgChannel -> FS.MsgChannel -> ByteString -> PortNumber
  76            -> String -> [String] -> Integer -> IO ()
  77 runTracker msgChannel fsChan infohash port peerId announceList sz = do
  78   ps <- newEmptyMVar
  79   let initialTState = TState { currentState = None
  80                              , connectedPeers = ps
  81                              , left = sz }
  82       turl = head announceList
  83       host = getHostname turl
  84   case getTrackerType turl of
  85     Http -> do
  86       _ <- forkIO $ HT.trackerLoop host port peerId infohash fsChan initialTState
  87       runStateT (msgHandler msgChannel) initialTState
  88       return ()
  89     Udp -> do
  90       _ <- forkIO $ UT.trackerLoop host (fromIntegral port) peerId infohash fsChan initialTState
  91       return ()
  92     _ ->
  93       error "Tracker Protocol unimplemented"
  94
  95 msgHandler :: MsgChannel -> StateT TState IO ()
  96 msgHandler c = forever $ do
  97   st <- get
  98   peers <- liftIO $ readMVar (connectedPeers st)
  99   msg <- liftIO recvMsg
 100   liftIO $ sendResponse msg peers
 101     where
 102       recvMsg = readChan c
 103       sendResponse msg peers =
 104         case msg of
 105           GetConnectedPeersMsg var -> do
 106             putMVar var peers
 107           _ -> do
 108             putStrLn "Unhandled Tracker Msg"
 109
 110 getConnectedPeers :: MsgChannel -> IO [Peer]
 111 getConnectedPeers c = do
 112   v <- newEmptyMVar
 113   writeChan c (GetConnectedPeersMsg v)
 114   ps <- readMVar v
 115   return ps