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, getHostname)
  40 import qualified FuncTorrent.FileSystem as FS (MsgChannel)
  41 import FuncTorrent.PeerMsgs (Peer)
  42
  43 type MsgChannel = Chan TrackerMsg
  44
  45 newTracker :: IO MsgChannel
  46 newTracker = newChan
  47
  48 runTracker :: MsgChannel -> FS.MsgChannel -> ByteString -> PortNumber
  49            -> String -> [String] -> Integer -> IO ()
  50 runTracker msgChannel fsChan infohash port peerId announceList sz = do
  51   ps <- newEmptyMVar
  52   let initialTState = TState { currentState = None
  53                              , connectedPeers = ps
  54                              , left = sz }
  55       turl = head announceList
  56       host = getHostname turl
  57   case getTrackerType turl of
  58     Http -> do
  59       _ <- forkIO $ HT.trackerLoop turl port peerId infohash fsChan initialTState
  60       runStateT (msgHandler msgChannel) initialTState
  61       return ()
  62     Udp -> do
  63       _ <- forkIO $ UT.trackerLoop turl (fromIntegral port) peerId infohash fsChan initialTState
  64       runStateT (msgHandler msgChannel) initialTState
  65       return ()
  66     _ ->
  67       error "Tracker Protocol unimplemented"
  68
  69 getTrackerType :: String -> TrackerProtocol
  70 getTrackerType url | "http://" `isPrefixOf` url = Http
  71                    | "udp://" `isPrefixOf` url  = Udp
  72                    | otherwise                  = UnknownProtocol
  73
  74
  75 msgHandler :: MsgChannel -> StateT TState IO ()
  76 msgHandler c = forever $ do
  77   st <- get
  78   peers <- liftIO $ readMVar (connectedPeers st)
  79   msg <- liftIO recvMsg
  80   liftIO $ sendResponse msg peers
  81     where
  82       recvMsg = readChan c
  83       sendResponse msg peers =
  84         case msg of
  85           GetConnectedPeersMsg var ->
  86             putMVar var peers
  87           _ ->
  88             putStrLn "Unhandled Tracker Msg"
  89
  90 getConnectedPeers :: MsgChannel -> IO [Peer]
  91 getConnectedPeers c = do
  92   v <- newEmptyMVar
  93   writeChan c (GetConnectedPeersMsg v)
  94   readMVar v