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
|
module WebSocket (
Connection,
startClient,
startDefaultWebSocketConnections,
sendMessage,
receiveMessage,
) where
import Control.Concurrent
import Control.Monad
import Data.ByteString (ByteString)
import Data.ByteString.Unsafe
import Data.Function
import Data.Unique
import Data.Word
import Erebos.Network
import Foreign.Marshal.Alloc
import Foreign.Ptr
import GHC.Wasm.Prim
import JavaScript
import JavaScript.Val
data Connection = Connection
{ connUnique :: Unique
, connAddress :: String
, connJS :: WebSocket
, connInQueue :: Chan ByteString
}
instance Eq Connection where
(==) = (==) `on` connUnique
instance Ord Connection where
compare = compare `on` connUnique
instance Show Connection where
show = connAddress
instance PeerAddressType Connection where
sendBytesToAddress = sendMessage
connectionToAddressClosed = closeConnection
isReliableTransport _ = True
startClient :: Server -> String -> Int -> String -> (Connection -> IO ()) -> IO ()
startClient server addr port path fun = do
connUnique <- newUnique
let connAddress = "wss://" <> addr <> ":" <> show port <> "/" <> path
connJS <- initWebSocket connAddress
connInQueue <- newChan
let conn = Connection {..}
addEventListener connJS "open" $ \_ -> do
fun conn
addEventListener connJS "message" $ \ev -> do
bytes <- js_get_data $ toJSVal ev
len <- js_get_byteLength bytes
ptr <- mallocBytes len
js_copyBytes ptr bytes
bs <- unsafePackCStringFinalizer ptr len (free ptr)
writeChan connInQueue bs
addEventListener connJS "close" $ \_ -> do
dropPeerAddress server $ CustomPeerAddress conn
addEventListener connJS "error" $ \_ -> do
dropPeerAddress server $ CustomPeerAddress conn
startDefaultWebSocketConnections :: Server -> IO ()
startDefaultWebSocketConnections server = do
peerVar <- newEmptyMVar
let doStart = do
startClient server "a.discovery.erebosprotocol.net" 443 "" $ \conn -> do
putMVar peerVar =<< serverPeerCustom server conn
void $ forkIO $ forever $ do
msg <- receiveMessage conn
receivedFromCustomAddress server conn msg
void $ forkIO $ void $ forever $ do
peer <- getNextPeerChange server
isPeerDropped peer >>= \case
True -> do
wsPeer <- takeMVar peerVar
if peer == wsPeer
then doStart
else putMVar peerVar wsPeer
False -> return ()
doStart
sendMessage :: Connection -> ByteString -> IO ()
sendMessage Connection {..} bs = do
unsafeUseAsCStringLen bs $ \( ptr, len ) -> do
js_send (toJSVal connJS) (castPtr ptr) len >>= \case
0 -> return ()
1 -> error "websocket is not open"
receiveMessage :: Connection -> IO ByteString
receiveMessage Connection {..} = do
readChan connInQueue
closeConnection :: Connection -> IO ()
closeConnection Connection {..} = do
js_close (toJSVal connJS)
newtype WebSocket = WebSocket JSVal
deriving (FromJSVal, ToJSVal)
instance IsEventTarget WebSocket where
toEventTarget = fromJSValUnchecked . toJSVal
initWebSocket :: String -> IO WebSocket
initWebSocket addr = WebSocket <$> js_initWebSocket (toJSString addr)
foreign import javascript unsafe "const ws = new WebSocket($1); ws.binaryType = 'arraybuffer'; return ws"
js_initWebSocket :: JSString -> IO JSVal
foreign import javascript unsafe "if ($1.readyState == WebSocket.OPEN) { $1.send(new Uint8Array(globalThis.wasi_memory.buffer, $2, $3)); return 0; } else { return 1; }"
js_send :: JSVal -> Ptr Word8 -> Int -> IO Int
foreign import javascript unsafe "$1.close()"
js_close :: JSVal -> IO ()
foreign import javascript unsafe "$1.data"
js_get_data :: JSVal -> IO JSVal
foreign import javascript unsafe "$1.byteLength"
js_get_byteLength :: JSVal -> IO Int
foreign import javascript unsafe "new Uint8Array(globalThis.wasi_memory.buffer, $1, $2.byteLength).set(new Uint8Array($2))"
js_copyBytes :: Ptr Word8 -> JSVal -> IO ()
|