blob: 3f91387c9076802ec90359039c662ac92f828951 (
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
|
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
module Data.Tox.DHT.Multi where
import qualified Network.Tox.NodeId as UDP
;import Network.Tox.NodeId (NodeId)
import qualified Network.Tox.TCP.NodeId as TCP
import Data.Tox.Relay
import Network.Address (either4or6)
import Network.Tox.TCP as TCP (ViaRelay(..))
import Network.QueryResponse (Tagged(..))
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"
-- 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
data A addr where
AddrUDP :: SockAddr -> A UDP.NodeInfo
AddrTCP :: Maybe ConId -> TCP.NodeInfo -> A TCP.ViaRelay
deriving instance Eq (A addr)
type NodeInfo = DSum T Identity
type SessionAddress = DSum S Identity
type Address = DSum T A
#if MIN_VERSION_dependent_sum(0,6,0)
deriveArgDict ''T
deriveArgDict ''S
#else
instance ShowTag T Identity where
showTaggedPrec UDP = showsPrec
showTaggedPrec TCP = showsPrec
instance ShowTag S Identity where
showTaggedPrec SessionUDP = showsPrec
showTaggedPrec SessionTCP = 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 T A -> Either String (DSum T Identity )
nodeInfo nid (UDP :=> AddrUDP saddr ) = fmap (UDP ==>) $ UDP.nodeInfo nid saddr
nodeInfo nid (TCP :=> AddrTCP conid relay) = Right $ TCP ==> ViaRelay conid nid relay
nodeAddr :: DSum T Identity -> DSum T A
nodeAddr (UDP :=> Identity ni ) = UDP :=> AddrUDP (UDP.nodeAddr ni)
nodeAddr (TCP :=> Identity (ViaRelay conid _ relay)) = TCP :=> AddrTCP conid relay
-}
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
|
