diff options
Diffstat (limited to 'src/Network/BitTorrent/Exchange/Wire.hs')
-rw-r--r-- | src/Network/BitTorrent/Exchange/Wire.hs | 205 |
1 files changed, 205 insertions, 0 deletions
diff --git a/src/Network/BitTorrent/Exchange/Wire.hs b/src/Network/BitTorrent/Exchange/Wire.hs new file mode 100644 index 00000000..dd77a915 --- /dev/null +++ b/src/Network/BitTorrent/Exchange/Wire.hs | |||
@@ -0,0 +1,205 @@ | |||
1 | -- | | ||
2 | -- | ||
3 | -- Message flow | ||
4 | -- Duplex channell | ||
5 | -- This module control /integrity/ of data send and received. | ||
6 | -- | ||
7 | |||
8 | {-# LANGUAGE DeriveDataTypeable #-} | ||
9 | module Network.BitTorrent.Exchange.Wire | ||
10 | ( -- * Exception | ||
11 | ProtocolError (..) | ||
12 | , WireFailure (..) | ||
13 | , isWireFailure | ||
14 | |||
15 | -- * Wire | ||
16 | , Connection (..) | ||
17 | , Wire | ||
18 | , runWire | ||
19 | , connectWire | ||
20 | , acceptWire | ||
21 | ) where | ||
22 | |||
23 | import Control.Exception | ||
24 | import Control.Monad.Reader | ||
25 | import Data.ByteString as BS | ||
26 | import Data.Conduit | ||
27 | import Data.Conduit.Cereal as S | ||
28 | import Data.Conduit.Network | ||
29 | import Data.Default | ||
30 | import Data.Maybe | ||
31 | import Data.Monoid | ||
32 | import Data.Serialize as S | ||
33 | import Data.Typeable | ||
34 | import Network | ||
35 | import Network.Socket | ||
36 | import Network.Socket.ByteString as BS | ||
37 | import Text.PrettyPrint as PP hiding (($$), (<>)) | ||
38 | import Text.PrettyPrint.Class | ||
39 | |||
40 | import Data.Torrent.InfoHash | ||
41 | import Network.BitTorrent.Core.PeerId | ||
42 | import Network.BitTorrent.Core.PeerAddr | ||
43 | import Network.BitTorrent.Exchange.Message | ||
44 | |||
45 | |||
46 | {----------------------------------------------------------------------- | ||
47 | -- Exceptions | ||
48 | -----------------------------------------------------------------------} | ||
49 | |||
50 | data ChannelSide | ||
51 | = ThisPeer | ||
52 | | RemotePeer | ||
53 | deriving (Show, Eq, Enum) | ||
54 | |||
55 | -- | Errors occur when a remote peer violates protocol specification. | ||
56 | data ProtocolError | ||
57 | = UnexpectedTopic InfoHash -- ^ peer replied with unexpected infohash. | ||
58 | | UnexpectedPeerId PeerId -- ^ peer replied with unexpected peer id. | ||
59 | | UnknownTopic InfoHash -- ^ peer requested unknown torrent. | ||
60 | | InvalidMessage | ||
61 | { violentSender :: ChannelSide -- ^ endpoint sent invalid message | ||
62 | , extensionRequired :: Extension -- ^ | ||
63 | } | ||
64 | deriving Show | ||
65 | |||
66 | instance Pretty ProtocolError where | ||
67 | pretty = PP.text . show | ||
68 | |||
69 | -- | Exceptions used to interrupt the current P2P session. | ||
70 | data WireFailure | ||
71 | = PeerDisconnected -- ^ A peer not responding. | ||
72 | | DisconnectPeer -- ^ | ||
73 | | ProtocolError ProtocolError | ||
74 | deriving (Show, Typeable) | ||
75 | |||
76 | instance Exception WireFailure | ||
77 | |||
78 | instance Pretty WireFailure where | ||
79 | pretty = PP.text . show | ||
80 | |||
81 | -- | Do nothing with exception, used with 'handle' or 'try'. | ||
82 | isWireFailure :: Monad m => WireFailure -> m () | ||
83 | isWireFailure _ = return () | ||
84 | |||
85 | {----------------------------------------------------------------------- | ||
86 | -- Connection | ||
87 | -----------------------------------------------------------------------} | ||
88 | |||
89 | data Connection = Connection | ||
90 | { connCaps :: !Caps | ||
91 | , connExtCaps :: !ExtendedCaps -- TODO caps can be enabled during communication | ||
92 | , connTopic :: !InfoHash | ||
93 | , connRemotePeerId :: !PeerId | ||
94 | , connThisPeerId :: !PeerId | ||
95 | } deriving Show | ||
96 | |||
97 | instance Pretty Connection where | ||
98 | pretty Connection {..} = "Connection" | ||
99 | |||
100 | isAllowed :: Connection -> Message -> Bool | ||
101 | isAllowed Connection {..} msg | ||
102 | | Just ext <- requires msg = allowed connCaps ext | ||
103 | | otherwise = True | ||
104 | |||
105 | {----------------------------------------------------------------------- | ||
106 | -- Hanshaking | ||
107 | -----------------------------------------------------------------------} | ||
108 | |||
109 | -- | TODO remove socket stuff to corresponding module | ||
110 | sendHandshake :: Socket -> Handshake -> IO () | ||
111 | sendHandshake sock hs = sendAll sock (S.encode hs) | ||
112 | |||
113 | recvHandshake :: Socket -> IO Handshake | ||
114 | recvHandshake sock = do | ||
115 | header <- BS.recv sock 1 | ||
116 | unless (BS.length header == 1) $ | ||
117 | throw $ userError "Unable to receive handshake header." | ||
118 | |||
119 | let protocolLen = BS.head header | ||
120 | let restLen = handshakeSize protocolLen - 1 | ||
121 | |||
122 | body <- BS.recv sock restLen | ||
123 | let resp = BS.cons protocolLen body | ||
124 | either (throwIO . userError) return $ S.decode resp | ||
125 | |||
126 | -- | Handshaking with a peer specified by the second argument. | ||
127 | -- | ||
128 | -- It's important to send handshake first because /accepting/ peer | ||
129 | -- do not know handshake topic and will wait until /connecting/ peer | ||
130 | -- will send handshake. | ||
131 | -- | ||
132 | initiateHandshake :: Socket -> Handshake -> IO Handshake | ||
133 | initiateHandshake sock hs = do | ||
134 | sendHandshake sock hs | ||
135 | recvHandshake sock | ||
136 | |||
137 | -- | Tries to connect to peer using reasonable default parameters. | ||
138 | connectToPeer :: PeerAddr -> IO Socket | ||
139 | connectToPeer p = do | ||
140 | sock <- socket AF_INET Stream Network.Socket.defaultProtocol | ||
141 | connect sock (peerSockAddr p) | ||
142 | return sock | ||
143 | |||
144 | {----------------------------------------------------------------------- | ||
145 | -- Wire | ||
146 | -----------------------------------------------------------------------} | ||
147 | |||
148 | type Wire = ConduitM Message Message (ReaderT Connection IO) | ||
149 | |||
150 | validate :: Wire () | ||
151 | validate = do | ||
152 | mmsg <- await | ||
153 | case mmsg of | ||
154 | Nothing -> return () | ||
155 | Just msg -> do | ||
156 | valid <- lift $ asks (`isAllowed` msg) | ||
157 | if valid then yield msg else error "TODO" | ||
158 | |||
159 | |||
160 | runWire :: Wire () -> Socket -> Connection -> IO () | ||
161 | runWire action sock = runReaderT $ | ||
162 | sourceSocket sock $= | ||
163 | S.conduitGet S.get $= | ||
164 | action $= | ||
165 | S.conduitPut S.put $$ | ||
166 | sinkSocket sock | ||
167 | |||
168 | sendMessage :: PeerMessage msg => msg -> Wire () | ||
169 | sendMessage msg = do | ||
170 | ecaps <- lift $ asks connExtCaps | ||
171 | yield $ envelop ecaps msg | ||
172 | |||
173 | recvMessage :: Wire Message | ||
174 | recvMessage = undefined | ||
175 | |||
176 | |||
177 | |||
178 | extendedHandshake :: Wire () | ||
179 | extendedHandshake = undefined | ||
180 | |||
181 | connectWire :: Handshake -> PeerAddr -> ExtendedCaps -> Wire () -> IO () | ||
182 | connectWire hs addr caps wire = | ||
183 | bracket (connectToPeer addr) close $ \ sock -> do | ||
184 | hs' <- initiateHandshake sock hs | ||
185 | |||
186 | unless (hsInfoHash hs == hsInfoHash hs') $ do | ||
187 | throwIO $ ProtocolError $ UnexpectedTopic (hsInfoHash hs') | ||
188 | |||
189 | unless (hsPeerId hs' == fromMaybe (hsPeerId hs') (peerID addr)) $ do | ||
190 | throwIO $ ProtocolError $ UnexpectedPeerId (hsPeerId hs') | ||
191 | |||
192 | let caps = hsReserved hs <> hsReserved hs' | ||
193 | if allowed caps ExtExtended | ||
194 | then return () else return () | ||
195 | |||
196 | runWire wire sock $ Connection | ||
197 | { connCaps = caps | ||
198 | , connExtCaps = def | ||
199 | , connTopic = hsInfoHash hs | ||
200 | , connRemotePeerId = hsPeerId hs' | ||
201 | , connThisPeerId = hsPeerId hs | ||
202 | } | ||
203 | |||
204 | acceptWire :: Wire () -> Socket -> IO () | ||
205 | acceptWire = undefined | ||