src/Network/BitTorrent/Exchange/Manager.hs


1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61

module Network.BitTorrent.Exchange.Manager
       ( Options (..)
       , Manager
       , Handler
       , newManager
       , closeManager
       ) where

import Control.Concurrent
import Control.Exception hiding (Handler)
import Control.Monad
import Data.Default
import Network.Socket

import Data.Torrent.InfoHash
import Network.BitTorrent.Core
import Network.BitTorrent.Exchange.Session
import Network.BitTorrent.Exchange.Wire hiding (Options)

data Options = Options
  { optBacklog  :: Int
  , optPeerAddr :: PeerAddr IP
  } deriving (Show, Eq)

instance Default Options where
  def = Options
    { optBacklog  = maxListenQueue
    , optPeerAddr = def
    }

data Manager = Manager
  { listener :: !ThreadId
  }

type Handler = InfoHash -> IO Session

handleNewConn :: Socket -> PeerAddr IP -> Handler -> IO ()
handleNewConn sock addr handler = do
  conn <- newPendingConnection sock addr
  ses  <- handler (pendingTopic conn) `onException` closePending conn
  attach conn ses

listenIncoming :: Options -> Handler -> IO ()
listenIncoming Options {..} handler = do
  bracket (socket AF_INET Stream defaultProtocol) close $ \ sock -> do
    bind sock (toSockAddr optPeerAddr)
    listen sock optBacklog
    forever $ do
      (conn, sockAddr) <- accept sock
      case fromSockAddr sockAddr of
        Nothing   -> return ()
        Just addr -> void $ forkIO $ handleNewConn sock addr handler

newManager :: Options -> Handler -> IO Manager
newManager opts handler = do
  tid <- forkIO $ listenIncoming opts handler
  return (Manager tid)

closeManager :: Manager -> IO ()
closeManager Manager {..} = do
  killThread listener