diff options
author | James Crayne <jim.crayne@gmail.com> | 2019-09-28 13:43:29 -0400 |
---|---|---|
committer | Joe Crayne <joe@jerkface.net> | 2020-01-01 19:27:53 -0500 |
commit | 11987749fc6e6d3e53ea737d46d5ab13a16faeb8 (patch) | |
tree | 5716463275c2d3e902889db619908ded2a73971c /bittorrent/src/Network/BitTorrent/Client.hs | |
parent | add2c76bced51fde5e9917e7449ef52be70faf87 (diff) |
Factor out some new libraries
word64-map:
Data.Word64Map
network-addr:
Network.Address
tox-crypto:
Crypto.Tox
lifted-concurrent:
Control.Concurrent.Lifted.Instrument
Control.Concurrent.Async.Lifted.Instrument
psq-wrap:
Data.Wrapper.PSQInt
Data.Wrapper.PSQ
minmax-psq:
Data.MinMaxPSQ
tasks:
Control.Concurrent.Tasks
kad:
Network.Kademlia
Network.Kademlia.Bootstrap
Network.Kademlia.Routing
Network.Kademlia.CommonAPI
Network.Kademlia.Persistence
Network.Kademlia.Search
Diffstat (limited to 'bittorrent/src/Network/BitTorrent/Client.hs')
-rw-r--r-- | bittorrent/src/Network/BitTorrent/Client.hs | 195 |
1 files changed, 0 insertions, 195 deletions
diff --git a/bittorrent/src/Network/BitTorrent/Client.hs b/bittorrent/src/Network/BitTorrent/Client.hs deleted file mode 100644 index c84290dd..00000000 --- a/bittorrent/src/Network/BitTorrent/Client.hs +++ /dev/null | |||
@@ -1,195 +0,0 @@ | |||
1 | {-# LANGUAGE FlexibleInstances #-} | ||
2 | {-# LANGUAGE TypeSynonymInstances #-} | ||
3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} | ||
4 | {-# LANGUAGE TemplateHaskell #-} | ||
5 | module Network.BitTorrent.Client | ||
6 | ( -- * Options | ||
7 | Options (..) | ||
8 | |||
9 | -- * Client session | ||
10 | , Client | ||
11 | |||
12 | -- ** Session data | ||
13 | , clientPeerId | ||
14 | , clientListenerPort | ||
15 | , allowedExtensions | ||
16 | |||
17 | -- ** Session initialization | ||
18 | , LogFun | ||
19 | , newClient | ||
20 | , closeClient | ||
21 | , withClient | ||
22 | , simpleClient | ||
23 | |||
24 | -- * BitTorrent monad | ||
25 | , MonadBitTorrent (..) | ||
26 | , BitTorrent | ||
27 | , runBitTorrent | ||
28 | , getClient | ||
29 | |||
30 | -- * Handle | ||
31 | , Handle | ||
32 | , handleTopic | ||
33 | , handleTrackers | ||
34 | , handleExchange | ||
35 | |||
36 | -- ** Construction | ||
37 | , TorrentSource (..) | ||
38 | , closeHandle | ||
39 | |||
40 | -- ** Query | ||
41 | , getHandle | ||
42 | , getIndex | ||
43 | |||
44 | -- ** Management | ||
45 | , start | ||
46 | , pause | ||
47 | , stop | ||
48 | ) where | ||
49 | |||
50 | import Control.Applicative | ||
51 | import Control.Exception | ||
52 | import Control.Concurrent | ||
53 | import Control.Concurrent.Chan.Split as CS | ||
54 | import Control.Monad.Logger | ||
55 | import Control.Monad.Trans | ||
56 | import Control.Monad.Trans.Resource | ||
57 | |||
58 | import Data.Default | ||
59 | import Data.HashMap.Strict as HM | ||
60 | import Data.Text | ||
61 | import Network | ||
62 | |||
63 | import Data.Torrent | ||
64 | import Network.Address | ||
65 | import Network.BitTorrent.Client.Types | ||
66 | import Network.BitTorrent.Client.Handle | ||
67 | import Network.BitTorrent.DHT as DHT hiding (Options) | ||
68 | import Network.BitTorrent.Tracker as Tracker hiding (Options) | ||
69 | import Network.BitTorrent.Exchange as Exchange hiding (Options) | ||
70 | import qualified Network.BitTorrent.Exchange as Exchange (Options(..)) | ||
71 | |||
72 | |||
73 | data Options = Options | ||
74 | { optFingerprint :: Fingerprint | ||
75 | , optName :: Text | ||
76 | , optPort :: PortNumber | ||
77 | , optExtensions :: [Extension] | ||
78 | , optNodeAddr :: NodeAddr IPv4 | ||
79 | , optBootNode :: Maybe (NodeAddr IPv4) | ||
80 | } | ||
81 | |||
82 | instance Default Options where | ||
83 | def = Options | ||
84 | { optFingerprint = def | ||
85 | , optName = "hs-bittorrent" | ||
86 | , optPort = 6882 | ||
87 | , optExtensions = [] | ||
88 | , optNodeAddr = "0.0.0.0:6882" | ||
89 | , optBootNode = Nothing | ||
90 | } | ||
91 | |||
92 | exchangeOptions :: PeerId -> Options -> Exchange.Options | ||
93 | exchangeOptions pid Options {..} = Exchange.Options | ||
94 | { optPeerAddr = PeerAddr (Just pid) (peerHost def) optPort | ||
95 | , optBacklog = optBacklog def | ||
96 | } | ||
97 | |||
98 | connHandler :: MVar (HashMap InfoHash Handle) -> Exchange.Handler | ||
99 | connHandler tmap ih = do | ||
100 | m <- readMVar tmap | ||
101 | case HM.lookup ih m of | ||
102 | Nothing -> error "torrent not found" | ||
103 | Just (Handle {..}) -> return handleExchange | ||
104 | |||
105 | initClient :: Options -> LogFun -> ResIO Client | ||
106 | initClient opts @ Options {..} logFun = do | ||
107 | pid <- liftIO genPeerId | ||
108 | tmap <- liftIO $ newMVar HM.empty | ||
109 | |||
110 | let peerInfo = PeerInfo pid Nothing optPort | ||
111 | let mkTracker = Tracker.newManager def peerInfo | ||
112 | (_, tmgr) <- allocate mkTracker Tracker.closeManager | ||
113 | |||
114 | let mkEx = Exchange.newManager (exchangeOptions pid opts) (connHandler tmap) | ||
115 | (_, emgr) <- allocate mkEx Exchange.closeManager | ||
116 | |||
117 | let mkNode = DHT.newNode defaultHandlers def optNodeAddr logFun Nothing | ||
118 | (_, node) <- allocate mkNode DHT.closeNode | ||
119 | |||
120 | resourceMap <- getInternalState | ||
121 | eventStream <- liftIO newSendPort | ||
122 | |||
123 | return Client | ||
124 | { clientPeerId = pid | ||
125 | , clientListenerPort = optPort | ||
126 | , allowedExtensions = toCaps optExtensions | ||
127 | , clientResources = resourceMap | ||
128 | , trackerManager = tmgr | ||
129 | , exchangeManager = emgr | ||
130 | , clientNode = node | ||
131 | , clientTorrents = tmap | ||
132 | , clientLogger = logFun | ||
133 | , clientEvents = eventStream | ||
134 | } | ||
135 | |||
136 | newClient :: Options -> LogFun -> IO Client | ||
137 | newClient opts logFun = do | ||
138 | s <- createInternalState | ||
139 | runInternalState (initClient opts logFun) s | ||
140 | `onException` closeInternalState s | ||
141 | |||
142 | closeClient :: Client -> IO () | ||
143 | closeClient Client {..} = closeInternalState clientResources | ||
144 | |||
145 | withClient :: Options -> LogFun -> (Client -> IO a) -> IO a | ||
146 | withClient opts lf action = bracket (newClient opts lf) closeClient action | ||
147 | |||
148 | -- do not perform IO in 'initClient', do it in the 'boot' | ||
149 | --boot :: BitTorrent () | ||
150 | --boot = do | ||
151 | -- Options {..} <- asks options | ||
152 | -- liftDHT $ bootstrap (maybeToList optBootNode) | ||
153 | |||
154 | -- | Run bittorrent client with default options and log to @stderr@. | ||
155 | -- | ||
156 | -- For testing purposes only. | ||
157 | -- | ||
158 | simpleClient :: BitTorrent () -> IO () | ||
159 | simpleClient m = do | ||
160 | runStderrLoggingT $ LoggingT $ \ logger -> do | ||
161 | withClient def logger (`runBitTorrent` m) | ||
162 | |||
163 | {----------------------------------------------------------------------- | ||
164 | -- Torrent identifiers | ||
165 | -----------------------------------------------------------------------} | ||
166 | |||
167 | class TorrentSource s where | ||
168 | openHandle :: FilePath -> s -> BitTorrent Handle | ||
169 | |||
170 | instance TorrentSource InfoHash where | ||
171 | openHandle path ih = openMagnet path (nullMagnet ih) | ||
172 | {-# INLINE openHandle #-} | ||
173 | |||
174 | instance TorrentSource Magnet where | ||
175 | openHandle = openMagnet | ||
176 | {-# INLINE openHandle #-} | ||
177 | |||
178 | instance TorrentSource InfoDict where | ||
179 | openHandle path dict = openTorrent path (nullTorrent dict) | ||
180 | {-# INLINE openHandle #-} | ||
181 | |||
182 | instance TorrentSource Torrent where | ||
183 | openHandle = openTorrent | ||
184 | {-# INLINE openHandle #-} | ||
185 | |||
186 | instance TorrentSource FilePath where | ||
187 | openHandle contentDir torrentPath = do | ||
188 | t <- liftIO $ fromFile torrentPath | ||
189 | openTorrent contentDir t | ||
190 | {-# INLINE openHandle #-} | ||
191 | |||
192 | getIndex :: BitTorrent [Handle] | ||
193 | getIndex = do | ||
194 | Client {..} <- getClient | ||
195 | elems <$> liftIO (readMVar clientTorrents) | ||