blob: 4fe90cda7357506d49c2d098ecc262668ef98aa6 (
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
|
-- |
-- 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
) 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.Exchange.Selection
import Network.BitTorrent.Exchange.Protocol
import Network.BitTorrent.Internal
import Network.BitTorrent.Extension
import Network.BitTorrent.Peer
import Data.Bitfield as BF
import Data.Torrent
{-----------------------------------------------------------------------
P2P monad
-----------------------------------------------------------------------}
type PeerWire = ConduitM Message Message IO
waitMessage :: PeerWire Message
waitMessage = await >>= maybe waitMessage return
signalMessage :: Message -> PeerWire ()
signalMessage = C.yield
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)
data Event = Available Bitfield
| Want
| Block
waitForEvent :: P2P Event
waitForEvent = P2P (ReaderT nextEvent)
where
nextEvent se @ PeerSession {..} = waitMessage >>= diff
where
-- diff finds difference between
diff KeepAlive = do
signalMessage KeepAlive
nextEvent se
handleMessage Choke = do
SessionStatus {..} <- liftIO $ readIORef peerSessionStatus
if psChoking sePeerStatus
then nextEvent se
else undefined
handleMessage Unchoke = 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 (Piece blk) = undefined
handleMessage (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 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)
getPieceCount :: PeerSession -> IO PieceCount
getPieceCount = undefined
signalEvent :: Event -> P2P ()
signalEvent = undefined
|
