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
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
|
module Network.BitTorrent.Client.Handle
( -- * Handle
Handle
-- * Initialization
, openTorrent
, openMagnet
, closeHandle
-- * Control
, start
, pause
, stop
-- * Query
, getHandle
, getStatus
) where
import Control.Concurrent.Chan.Split
import Control.Concurrent.Lifted as L
import Control.Monad
import Control.Monad.Trans
import Data.Default
import Data.List as L
import Data.HashMap.Strict as HM
import Data.Torrent
import Network.BitTorrent.Client.Types as Types
import Network.BitTorrent.DHT as DHT
import Network.BitTorrent.Exchange as Exchange
import Network.BitTorrent.Tracker as Tracker
{-----------------------------------------------------------------------
-- Safe handle set manupulation
-----------------------------------------------------------------------}
allocHandle :: InfoHash -> BitTorrent Handle -> BitTorrent Handle
allocHandle ih m = do
Client {..} <- getClient
(h, added) <- modifyMVar clientTorrents $ \ handles -> do
case HM.lookup ih handles of
Just h -> return (handles, (h, False))
Nothing -> do
h <- m
return (HM.insert ih h handles, (h, True))
when added $ do
liftIO $ send clientEvents (TorrentAdded ih)
return h
freeHandle :: InfoHash -> BitTorrent () -> BitTorrent ()
freeHandle ih finalizer = do
Client {..} <- getClient
modifyMVar_ clientTorrents $ \ handles -> do
case HM.lookup ih handles of
Nothing -> return handles
Just _ -> do
finalizer
return (HM.delete ih handles)
lookupHandle :: InfoHash -> BitTorrent (Maybe Handle)
lookupHandle ih = do
Client {..} <- getClient
handles <- readMVar clientTorrents
return (HM.lookup ih handles)
{-----------------------------------------------------------------------
-- Initialization
-----------------------------------------------------------------------}
newExchangeSession :: FilePath -> Either InfoHash InfoDict -> BitTorrent Exchange.Session
newExchangeSession rootPath source = do
c @ Client {..} <- getClient
liftIO $ Exchange.newSession clientLogger (externalAddr c) rootPath source
-- | Open a torrent in 'stop'ed state. Use 'nullTorrent' to open
-- handle from 'InfoDict'. This operation do not block.
openTorrent :: FilePath -> Torrent -> BitTorrent Handle
openTorrent rootPath t @ Torrent {..} = do
let ih = idInfoHash tInfoDict
allocHandle ih $ do
statusVar <- newMVar Types.Stopped
tses <- liftIO $ Tracker.newSession ih (trackerList t)
eses <- newExchangeSession rootPath (Right tInfoDict)
eventStream <- liftIO newSendPort
return $ Handle
{ handleTopic = ih
, handlePrivate = idPrivate tInfoDict
, handleStatus = statusVar
, handleTrackers = tses
, handleExchange = eses
, handleEvents = eventStream
}
-- | Use 'nullMagnet' to open handle from 'InfoHash'.
openMagnet :: FilePath -> Magnet -> BitTorrent Handle
openMagnet rootPath Magnet {..} = do
allocHandle exactTopic $ do
statusVar <- newMVar Types.Stopped
tses <- liftIO $ Tracker.newSession exactTopic def
eses <- newExchangeSession rootPath (Left exactTopic)
eventStream <- liftIO newSendPort
return $ Handle
{ handleTopic = exactTopic
, handlePrivate = False
, handleStatus = statusVar
, handleTrackers = tses
, handleExchange = eses
, handleEvents = eventStream
}
-- | Stop torrent and destroy all sessions. You don't need to close
-- handles at application exit, all handles will be automatically
-- closed at 'Network.BitTorrent.Client.closeClient'. This operation
-- may block.
closeHandle :: Handle -> BitTorrent ()
closeHandle h @ Handle {..} = do
freeHandle handleTopic $ do
Client {..} <- getClient
stop h
liftIO $ Exchange.closeSession handleExchange
liftIO $ Tracker.closeSession trackerManager handleTrackers
{-----------------------------------------------------------------------
-- Control
-----------------------------------------------------------------------}
modifyStatus :: HandleStatus -> Handle -> (HandleStatus -> BitTorrent ()) -> BitTorrent ()
modifyStatus targetStatus Handle {..} targetAction = do
modifyMVar_ handleStatus $ \ actualStatus -> do
unless (actualStatus == targetStatus) $ do
targetAction actualStatus
return targetStatus
liftIO $ send handleEvents (StatusChanged targetStatus)
-- | Start downloading, uploading and announcing this torrent.
--
-- This operation is blocking, use
-- 'Control.Concurrent.Async.Lifted.async' if needed.
start :: Handle -> BitTorrent ()
start h @ Handle {..} = do
modifyStatus Types.Running h $ \ status -> do
case status of
Types.Running -> return ()
Types.Stopped -> do
Client {..} <- getClient
liftIO $ Tracker.notify trackerManager handleTrackers Tracker.Started
unless handlePrivate $ do
liftDHT $ DHT.insert handleTopic (error "start")
liftIO $ do
peers <- askPeers trackerManager handleTrackers
print $ "got: " ++ show (L.length peers) ++ " peers"
forM_ peers $ \ peer -> do
Exchange.connect peer handleExchange
-- | Stop downloading this torrent.
pause :: Handle -> BitTorrent ()
pause _ = return ()
-- | Stop downloading, uploading and announcing this torrent.
stop :: Handle -> BitTorrent ()
stop h @ Handle {..} = do
modifyStatus Types.Stopped h $ \ status -> do
case status of
Types.Stopped -> return ()
Types.Running -> do
Client {..} <- getClient
unless handlePrivate $ do
liftDHT $ DHT.delete handleTopic (error "stop")
liftIO $ Tracker.notify trackerManager handleTrackers Tracker.Stopped
{-----------------------------------------------------------------------
-- Query
-----------------------------------------------------------------------}
getHandle :: InfoHash -> BitTorrent Handle
getHandle ih = do
mhandle <- lookupHandle ih
case mhandle of
Nothing -> error "should we throw some exception?"
Just h -> return h
getStatus :: Handle -> IO HandleStatus
getStatus Handle {..} = readMVar handleStatus
|
