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
|
{-# LANGUAGE TupleSections #-}
module Network.BitTorrent.Tracker.Transport
( implementTracker
, Callbacks(..)
, parseTracker
, encodeTracker
) where
import Control.Concurrent.STM
import Crypto.Random
import Data.ByteString (ByteString)
import Data.Functor.Contravariant
import Data.IntMap.Strict (IntMap)
import qualified Data.Serialize as S
import Network.Socket (SockAddr)
import Data.QueryResponse.Table
import Data.TableMethods
import Network.Address
import Network.BitTorrent.Tracker.Message
import Network.QueryResponse as QR
-- | For use with 'layerTransport'.
parseTracker :: ByteString -> SockAddr -> Either String (Transaction Request, SockAddr)
parseTracker bs saddr = fmap (, saddr) $ S.decode bs
-- | For use with 'layerTransport'.
encodeTracker :: Transaction Response -> SockAddr -> (ByteString, SockAddr)
encodeTracker resp saddr = (S.encode resp,saddr)
type Handler = MethodHandlerA String TransactionId SockAddr (Transaction Request) (Transaction Response)
type Client = QR.ClientA String MessageId TransactionId SockAddr (Transaction Request) (Transaction Response)
-- | Handlers for inbound tracker requests. It is safe to throw 'DropQuery'
-- from these, which should be done if the ConnectionId for an address does not
-- match the one issued by the 'callOnConnect' method.
data Callbacks = Callbacks
{ callOnConnect :: SockAddr -> IO ConnectionId
, callOnAnnounce :: SockAddr -> ConnectionId -> AnnounceQuery -> IO AnnounceInfo
, callOnScrape :: SockAddr -> ConnectionId -> ScrapeQuery -> IO [ScrapeEntry]
}
handlers :: Callbacks -> MessageId -> Maybe Handler
handlers c ConnectId = Just $ MethodHandler (const $ Right ())
(\qid from to conid -> TransactionR qid $ Connected conid)
(\from () -> callOnConnect c from)
handlers c AnnounceId = Just $ MethodHandler (\TransactionQ{connIdQ=cid,request=Announce qry} -> Right (cid,qry))
(\qid from to info -> TransactionR qid $ Announced info)
(uncurry . callOnAnnounce c)
handlers c ScrapeId = Just $ MethodHandler (\TransactionQ{connIdQ=cid,request=Scrape qry} -> Right (cid,qry))
(\qid from to entries -> TransactionR qid $ Scraped entries)
(uncurry . callOnScrape c)
handlers c ErrorId = Nothing
handlers c _ = Nothing
methodOfRequest :: Request -> MessageId
methodOfRequest Connect {} = ConnectId
methodOfRequest Announce {} = AnnounceId
methodOfRequest Scrape {} = ScrapeId
classify :: Transaction Request -> MessageClass String MessageId TransactionId SockAddr (Transaction Request)
classify qry = IsQuery (methodOfRequest $ request qry) (transIdQ qry)
dispatch :: DRG g =>
Callbacks
-> DispatchMethodsA
(g, IntMap (Maybe (Transaction Request) -> IO ()))
String
MessageId
TransactionId
SockAddr
(Transaction Request)
(Transaction Response)
dispatch c = DispatchMethods
{ classifyInbound = classify
, lookupHandler = handlers c
, tableMethods = transactionMethods (contramap fromEnum intMapMethods) genTransactionId
}
implementTracker :: ErrorReporter SockAddr (Transaction Request) MessageId TransactionId String
-> TransportA String SockAddr (Transaction Request) (Transaction Response)
-> Callbacks
-> IO (TransportA String SockAddr (Transaction Request) (Transaction Response))
implementTracker err net c = do
drg <- drgNew
state <- newTVarIO (drg, mempty)
let client = QR.Client
{ clientNet = net
, clientDispatcher = dispatch c
, clientErrorReporter = err
, clientPending = state
, clientAddress = const $ return localhost4
, clientResponseId = return
}
return $ addHandler (\err -> return ()) (handleMessage client) net
|
