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