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