blob: acd645a35edeefc1629e1ab319fa6e53264d3cd3 (
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
|
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
module Data.Tox.DHT.Multi where
import Crypto.PubKey.Curve25519 (PublicKey)
import qualified Network.Tox.NodeId as UDP
;import Network.Tox.NodeId (NodeId)
import qualified Network.Tox.TCP.NodeId as TCP
import Data.Tox.Onion (OnionDestination,RouteId)
import Data.Tox.Relay hiding (NodeInfo)
import Network.Address (either4or6)
import Network.Tox.TCP as TCP (ViaRelay(..), tcpConnectionRequest_)
import Network.QueryResponse as QR (Tagged(..), Client)
import Data.Dependent.Sum
import Data.GADT.Compare
import Data.GADT.Show
import Data.Functor.Identity
import Data.Typeable
import Network.Socket
#if MIN_VERSION_dependent_sum(0,6,0)
import Data.Constraint.Compose
import Data.Constraint.Extras
import Data.Constraint.Extras.TH
#endif
data T ni where
UDP :: T UDP.NodeInfo
TCP :: T TCP.ViaRelay
instance GEq T where
geq UDP UDP = Just Refl
geq TCP TCP = Just Refl
geq _ _ = Nothing
instance GCompare T where
gcompare UDP UDP = GEQ
gcompare UDP TCP = GLT
gcompare TCP TCP = GEQ
gcompare TCP UDP = GGT
instance GShow T where
gshowsPrec _ UDP = showString "UDP"
gshowsPrec _ TCP = showString "TCP"
data S addr where
SessionUDP :: S SockAddr
SessionTCP :: S TCP.ViaRelay
instance GEq S where
geq SessionUDP SessionUDP = Just Refl
geq SessionTCP SessionTCP = Just Refl
geq _ _ = Nothing
instance GCompare S where
gcompare SessionUDP SessionUDP = GEQ
gcompare SessionUDP SessionTCP = GLT
gcompare SessionTCP SessionTCP = GEQ
gcompare SessionTCP SessionUDP = GGT
instance GShow S where
gshowsPrec _ SessionUDP = showString "UDP"
gshowsPrec _ SessionTCP = showString "TCP"
data O addr where
OnionUDP :: O (OnionDestination RouteId)
OnionTCP :: O (OnionDestination RouteId)
instance GEq O where
geq OnionUDP OnionUDP = Just Refl
geq OnionTCP OnionTCP = Just Refl
geq _ _ = Nothing
instance GCompare O where
gcompare OnionUDP OnionUDP = GEQ
gcompare OnionUDP OnionTCP = GLT
gcompare OnionTCP OnionTCP = GEQ
gcompare OnionTCP OnionUDP = GGT
instance GShow O where
gshowsPrec _ OnionUDP = showString "UDP"
gshowsPrec _ OnionTCP = showString "TCP"
untagOnion :: DSum O Identity -> OnionDestination RouteId
untagOnion (OnionUDP :=> Identity o) = o
untagOnion (OnionTCP :=> Identity o) = o
-- Canonical in case of 6-mapped-4 addresses.
canonize :: DSum S Identity -> DSum S Identity
canonize (SessionUDP :=> Identity saddr) = SessionUDP ==> either id id (either4or6 saddr)
canonize taddr = taddr
type NodeInfo = DSum T Identity
type SessionAddress = DSum S Identity
type OnionAddress = DSum O Identity
#if MIN_VERSION_dependent_sum(0,6,0)
deriveArgDict ''T
deriveArgDict ''S
deriveArgDict ''O
#else
instance ShowTag T Identity where
showTaggedPrec UDP = showsPrec
showTaggedPrec TCP = showsPrec
instance ShowTag S Identity where
showTaggedPrec SessionUDP = showsPrec
showTaggedPrec SessionTCP = showsPrec
instance ShowTag O Identity where
showTaggedPrec OnionUDP = showsPrec
showTaggedPrec OnionTCP = showsPrec
instance EqTag S Identity where
eqTagged SessionUDP SessionUDP = (==)
eqTagged SessionTCP SessionTCP = (==)
instance OrdTag S Identity where
compareTagged SessionUDP SessionUDP = compare
compareTagged SessionTCP SessionTCP = compare
#endif
nodeInfo :: NodeId -> DSum S Identity -> Either String (DSum T Identity)
nodeInfo nid (SessionUDP :=> Identity saddr) = fmap (UDP ==>) $ UDP.nodeInfo nid saddr
nodeInfo nid (SessionTCP :=> Identity taddr@(ViaRelay _ nid2 _)) =
if nid2 == nid then Right $ TCP ==> taddr
else Left $ "Cached dht-key doesn't match."
nodeId :: DSum T Identity -> NodeId
nodeId (UDP :=> Identity ni ) = UDP.nodeId ni
nodeId (TCP :=> Identity (ViaRelay _ nid _)) = nid
relayNodeId :: TCP.ViaRelay -> UDP.NodeId
relayNodeId (ViaRelay _ nid _) = nid
udpNode :: DSum T Identity -> Maybe UDP.NodeInfo
udpNode (UDP :=> Identity ni) = Just ni
udpNode _ = Nothing
sessionAddr :: DSum T Identity -> DSum S Identity
sessionAddr (UDP :=> Identity ni) = SessionUDP ==> UDP.nodeAddr ni
sessionAddr (TCP :=> Identity vr) = SessionTCP ==> vr
tcpConnectionRequest :: QR.Client err PacketNumber tid TCP.NodeInfo (Bool, RelayPacket)
-> PublicKey -> TCP.NodeInfo -> IO (Maybe NodeInfo)
tcpConnectionRequest client pubkey ni = do
mcon <- tcpConnectionRequest_ client pubkey ni
return $ fmap (\conid -> TCP ==> ViaRelay (Just conid) (UDP.key2id pubkey) ni) mcon
|
