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
|
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE LambdaCase #-}
module Connection where
import Control.Applicative
import Control.Arrow
import Control.Concurrent.STM
import Data.Bits
import Data.Word
import qualified Data.Map as Map
;import Data.Map (Map)
import Network.Socket (SockAddr(..))
import PingMachine
-- | This type indicates the current status of a connection. The type
-- parameter indicates protocol-specific status information. To present
-- information as a user-comprehensible string, use 'showStatus'.
data Status status
= Dormant
| InProgress status
| Established
deriving (Show,Eq,Ord,Functor)
-- | A policy indicates a desired connection status.
data Policy
= RefusingToConnect -- ^ We desire no connection.
| OpenToConnect -- ^ We will cooperate if a remote side initiates.
| TryingToConnect -- ^ We desire to be connected.
deriving (Eq,Ord,Show)
-- | Information obtained via the 'connectionStatus' interface to
-- 'Manager'.
data Connection status = Connection
{ connStatus :: Status status
, connPolicy :: Policy
}
deriving Functor
-- | A 'PeerAddress' identifies an active session. For inactive sessions, multiple
-- values may be feasible.
-- We use a 'SockAddr' as it is convenient for TCP and UDP connections. But if
-- that is not your use case, see 'uniqueAsKey'.
newtype PeerAddress = PeerAddress { peerAddress :: SockAddr }
deriving (Eq,Ord,Show)
-- | A 24-byte word.
data Uniq24 = Uniq24 !Word64 !Word64 !Word64
deriving (Eq,Ord,Show)
-- | Coerce a 'Uniq24' to a useable 'PeerAddress'. Note that this stores the
-- special value 0 into the port number of the underlying 'SockAddr' and thus
-- should be compatible for mixing together with TCP/UDP peers.
uniqueAsKey :: Uniq24 -> PeerAddress
uniqueAsKey (Uniq24 x y z) = PeerAddress $ SockAddrInet6 (fromIntegral 0) a bcde f
where
a = fromIntegral (x `shiftR` 32)
b = fromIntegral x
c = fromIntegral (y `shiftR` 32)
d = fromIntegral y
e = fromIntegral (z `shiftR` 32)
f = fromIntegral z
bcde = (b,c,d,e)
-- | Inverse of 'uniqueAsKey'
keyAsUnique :: PeerAddress -> Maybe Uniq24
keyAsUnique (PeerAddress (SockAddrInet6 0 a bcde f)) = Just $ Uniq24 x y z
where
(b,c,d,e) = bcde
x = (fromIntegral a `shiftL` 32) .|. fromIntegral b
y = (fromIntegral c `shiftL` 32) .|. fromIntegral d
z = (fromIntegral e `shiftL` 32) .|. fromIntegral f
keyAsUniq _ = Nothing
-- | This is an interface to make or query status information about connections
-- of a specific kind.
--
-- Type parameters:
--
-- /k/ names a connection. It should implement Ord, and can be parsed and
-- displayed using 'stringToKey' and 'showKey'.
--
-- /status/ indicates the progress of a connection. It is intended as a
-- parameter to the 'InProgress' constructor of 'Status'.
--
data Manager status k = Manager
{ -- | Connect or disconnect a connection.
setPolicy :: k -> Policy -> IO ()
-- | Lookup a connection status.
, status :: k -> STM (Connection status)
-- | Obtain a list of all known connections.
, connections :: STM [k]
-- | Parse a connection key out of a string. Inverse of 'showKey'.
, stringToKey :: String -> Maybe k
-- | Convert a progress value to a string.
, showProgress :: status -> String
-- | Show a connection key as a string.
, showKey :: k -> String
-- | Obtain an address from a human-friendly name. For TCP/UDP
-- connections, this might be a forward-resolving DNS query.
, resolvePeer :: k -> IO [PeerAddress]
-- | This is the reverse of 'resolvePeer'. For TCP/UDP connections, this
-- might be a reverse-resolve DNS query.
, reverseAddress :: PeerAddress -> IO [k]
}
-- | Present status information (visible in a UI) for a connection.
showStatus :: Manager status k -> Status status -> String
showStatus mgr Dormant = "dormant"
showStatus mgr Established = "established"
showStatus mgr (InProgress s) = "in progress ("++showProgress mgr s++")"
-- | Combine two different species of 'Manager' into a single interface using
-- 'Either' to combine key and status types.
addManagers :: (Ord kA, Ord kB) =>
Manager statusA kA
-> Manager statusB kB
-> Manager (Either statusA statusB) (Either kA kB)
addManagers mgrA mgrB = Manager
{ setPolicy = either (setPolicy mgrA) (setPolicy mgrB)
, status = \case
Left k -> fmap Left <$> status mgrA k
Right k -> fmap Right <$> status mgrB k
, connections = do
as <- connections mgrA
bs <- connections mgrB
return $ map Left as ++ map Right bs
, stringToKey = \str -> Left <$> stringToKey mgrA str
<|> Right <$> stringToKey mgrB str
, showProgress = either (showProgress mgrA) (showProgress mgrB)
, showKey = either (showKey mgrA) (showKey mgrB)
}
|
