blob: 2173cf8bcd870646364368e877edb5717bc1da6d (
plain)
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
|
-- |
-- Copyright : (c) Sam T. 2013
-- License : MIT
-- Maintainer : pxqr.sta@gmail.com
-- Stability : experimental
-- Portability : portable
--
{-# LANGUAGE DoAndIfThenElse #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RecordWildCards #-}
module Network.BitTorrent.Exchange
( P2P, withPeer
, awaitEvent, signalEvent
) where
import Control.Applicative
import Control.Concurrent
import Control.Concurrent.STM
import Control.Exception
import Control.Monad.Reader
import Control.Monad.State
import Data.IORef
import Data.Function
import Data.Ord
import Data.Set as S
import Data.Conduit as C
import Data.Conduit.Cereal
import Data.Conduit.Network
import Data.Serialize as S
import Network
import Network.BitTorrent.Internal
import Network.BitTorrent.Extension
import Network.BitTorrent.Peer
import Network.BitTorrent.Exchange.Protocol
import Data.Bitfield as BF
import Data.Torrent
data Event = Available Bitfield
| Want
| Block
deriving Show
{-----------------------------------------------------------------------
Peer wire
-----------------------------------------------------------------------}
type PeerWire = ConduitM Message Message IO
waitMessage :: PeerSession -> PeerWire Message
waitMessage se = do
mmsg <- await
case mmsg of
Nothing -> waitMessage se
Just msg -> do
liftIO $ updateIncoming se
return msg
signalMessage :: Message -> PeerSession -> PeerWire ()
signalMessage msg se = do
C.yield msg
liftIO $ updateOutcoming se
getPieceCount :: PeerSession -> IO PieceCount
getPieceCount = undefined
nextEvent :: PeerSession -> PeerWire Event
nextEvent se @ PeerSession {..} = waitMessage se >>= diff
where
-- diff finds difference between
-- diff KeepAlive = nextEvent se
diff msg = do
liftIO $ print (ppMessage msg)
nextEvent se
handleMessage Choke = do
SessionStatus {..} <- liftIO $ readIORef peerSessionStatus
if psChoking sePeerStatus
then nextEvent se
else undefined
handleMessage Unchoke = undefined
--return $ Available BF.difference
handleMessage Interested = return undefined
handleMessage NotInterested = return undefined
handleMessage (Have ix) = do
pc <- liftIO $ getPieceCount se
haveMessage $ have ix (haveNone pc) -- TODO singleton
handleMessage (Bitfield bf) = undefined
handleMessage (Request bix) = do
undefined
handleMessage msg @ (Piece blk) = undefined
handleMessage msg @ (Port _)
= checkExtension msg ExtDHT $ do
undefined
handleMessage msg @ HaveAll
= checkExtension msg ExtFast $ do
pc <- liftIO $ getPieceCount se
haveMessage (haveAll pc)
handleMessage msg @ HaveNone
= checkExtension msg ExtFast $ do
pc <- liftIO $ getPieceCount se
haveMessage (haveNone pc)
handleMessage msg @ (SuggestPiece ix)
= checkExtension msg ExtFast $ do
undefined
handleMessage msg @ (RejectRequest ix)
= checkExtension msg ExtFast $ do
undefined
handleMessage msg @ (AllowedFast pix)
= checkExtension msg ExtFast $ do
undefined
haveMessage bf = do
cbf <- liftIO $ readIORef $ clientBitfield swarmSession
if undefined -- ix `member` bf
then nextEvent se
else undefined -- return $ Available diff
checkExtension msg requredExtension action
| requredExtension `elem` enabledExtensions = action
| otherwise = liftIO $ throwIO $ userError errorMsg
where
errorMsg = show (ppExtension requredExtension)
++ "not enabled, but peer sent"
++ show (ppMessage msg)
{-----------------------------------------------------------------------
P2P monad
-----------------------------------------------------------------------}
newtype P2P a = P2P {
runP2P :: ReaderT PeerSession PeerWire a
} deriving (Monad, MonadReader PeerSession, MonadIO)
instance MonadState Bitfield P2P where
runConduit :: Socket -> Conduit Message IO Message -> IO ()
runConduit sock p2p =
sourceSocket sock $=
conduitGet S.get $=
forever p2p $=
conduitPut S.put $$
sinkSocket sock
withPeer :: SwarmSession -> PeerAddr -> P2P () -> IO ()
withPeer se addr p2p =
withPeerSession se addr $ \(sock, pses) -> do
runConduit sock (runReaderT (runP2P p2p) pses)
awaitEvent :: P2P Event
awaitEvent = P2P (ReaderT nextEvent)
signalEvent :: Event -> P2P ()
signalEvent = undefined
|
