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
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Network.BitTorrent.Client
( -- * Options
Options (..)
-- * Client session
, Client
-- ** Session data
, clientPeerId
, clientListenerPort
, allowedExtensions
-- ** Session initialization
, newClient
, closeClient
, withClient
-- * BitTorrent monad
, BitTorrent
, runBitTorrent
, MonadBitTorrent (..)
, getClient
-- * Operations
, addTorrent
) where
import Control.Exception
import Control.Concurrent.STM
import Control.Monad.Logger
import Control.Monad.Reader
import Control.Monad.Trans.Resource
import Data.Default
import Data.Function
import Data.HashMap.Strict as HM
import Data.Maybe
import Data.Ord
import Data.Text
import Network
import System.Log.FastLogger
import Data.Torrent
import Data.Torrent.InfoHash
import Network.BitTorrent.Client.Swarm
import Network.BitTorrent.Core
import Network.BitTorrent.DHT
import Network.BitTorrent.Exchange.Message
data Options = Options
{ fingerprint :: Fingerprint
, name :: Text
, port :: PortNumber
, extensions :: [Extension]
, nodeAddr :: NodeAddr IPv4
, bootNode :: Maybe (NodeAddr IPv4)
}
instance Default Options where
def = Options
{ fingerprint = def
, name = "hs-bittorrent"
, port = 6882
, extensions = []
, nodeAddr = "0.0.0.0:6882"
, bootNode = Nothing
}
data Client = Client
{ clientPeerId :: !PeerId
, clientListenerPort :: !PortNumber
, allowedExtensions :: !Caps
, clientNode :: !(Node IPv4)
, clientTorrents :: !(TVar (HashMap InfoHash Swarm))
, clientLogger :: !LogFun
-- , trackerClient :: !(Manager)
}
instance Eq Client where
(==) = (==) `on` clientPeerId
instance Ord Client where
compare = comparing clientPeerId
newClient :: Options -> LogFun -> IO Client
newClient Options {..} logger = do
pid <- genPeerId
ts <- newTVarIO HM.empty
node <- runResourceT $ do
node <- startNode handlers def nodeAddr logger
runDHT node $ bootstrap (maybeToList bootNode)
return node
return Client
{ clientPeerId = pid
, clientListenerPort = port
, allowedExtensions = toCaps extensions
, clientTorrents = ts
, clientNode = node
, clientLogger = logger
}
closeClient :: Client -> IO ()
closeClient Client {..} = do
return ()
-- closeNode clientNode
withClient :: Options -> LogFun -> (Client -> IO a) -> IO a
withClient opts log action = bracket (newClient opts log) closeClient action
{-----------------------------------------------------------------------
-- BitTorrent monad
-----------------------------------------------------------------------}
class MonadBitTorrent m where
liftBT :: BitTorrent a -> m a
newtype BitTorrent a = BitTorrent
{ unBitTorrent :: ReaderT Client (ResourceT IO) a
} deriving (Monad, MonadIO)
instance MonadBitTorrent BitTorrent where
liftBT = id
instance MonadDHT BitTorrent where
liftDHT action = BitTorrent $ do
node <- asks clientNode
liftIO $ runResourceT $ runDHT node action
instance MonadLogger BitTorrent where
monadLoggerLog loc src lvl msg = BitTorrent $ do
logger <- asks clientLogger
liftIO $ logger loc src lvl (toLogStr msg)
runBitTorrent :: Client -> BitTorrent a -> IO a
runBitTorrent client action = runResourceT $
runReaderT (unBitTorrent action) client
{-# INLINE runBitTorrent #-}
getClient :: BitTorrent Client
getClient = BitTorrent ask
{-----------------------------------------------------------------------
-- Operations
-----------------------------------------------------------------------}
-- All operations should be non blocking!
addTorrent :: Torrent -> BitTorrent ()
addTorrent t = do
Client {..} <- getClient
liftIO $ do
leecher <- newLeecher clientPeerId clientListenerPort t
let ih = idInfoHash (tInfoDict t)
atomically $ modifyTVar' clientTorrents (HM.insert ih leecher)
askPeers leecher >>= print
|
