]> git.rkrishnan.org Git - functorrent.git/blob - src/FuncTorrent/Tracker.hs
tests: add license boilerplate
[functorrent.git] / 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