Remove useless JSON stuff, replace it with ArrayBuffer serialization.
parent
20207e7e73
commit
e1d49f1048
3
makefile
3
makefile
|
@ -6,6 +6,9 @@ build:
|
||||||
bundle:
|
bundle:
|
||||||
spago bundle-app
|
spago bundle-app
|
||||||
|
|
||||||
|
repl:
|
||||||
|
spago repl
|
||||||
|
|
||||||
serve:
|
serve:
|
||||||
npm run serve
|
npm run serve
|
||||||
|
|
||||||
|
|
106
src/Main.purs
106
src/Main.purs
|
@ -7,8 +7,9 @@ import Control.Monad.State (class MonadState)
|
||||||
import Data.Argonaut.Core as AC
|
import Data.Argonaut.Core as AC
|
||||||
import Data.Argonaut.Parser as AP
|
import Data.Argonaut.Parser as AP
|
||||||
import Data.Array as A
|
import Data.Array as A
|
||||||
import Data.Codec.Argonaut (JsonCodec, JsonDecodeError)
|
import Data.Bifunctor (lmap)
|
||||||
import Data.Codec.Argonaut as CA
|
-- import Data.Codec.Argonaut (JsonCodec, JsonDecodeError)
|
||||||
|
-- import Data.Codec.Argonaut as CA
|
||||||
import Data.Const (Const)
|
import Data.Const (Const)
|
||||||
import Data.Either (Either(..))
|
import Data.Either (Either(..))
|
||||||
import Data.List.NonEmpty (NonEmptyList)
|
import Data.List.NonEmpty (NonEmptyList)
|
||||||
|
@ -35,6 +36,11 @@ import Web.Socket.Event.MessageEvent as WSME
|
||||||
import Web.Socket.ReadyState (ReadyState(Connecting, Open, Closing, Closed))
|
import Web.Socket.ReadyState (ReadyState(Connecting, Open, Closing, Closed))
|
||||||
import Web.Socket.WebSocket as WS
|
import Web.Socket.WebSocket as WS
|
||||||
|
|
||||||
|
import Data.ArrayBuffer.Types (ArrayBuffer)
|
||||||
|
import Web.Socket.BinaryType (BinaryType(ArrayBuffer))
|
||||||
|
|
||||||
|
import App.IPC (toIPC, fromIPC)
|
||||||
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- WebSocketEvent type
|
-- WebSocketEvent type
|
||||||
|
@ -47,8 +53,8 @@ data WebSocketEvent msg
|
||||||
| WebSocketClose { code :: Int, reason :: String, wasClean :: Boolean }
|
| WebSocketClose { code :: Int, reason :: String, wasClean :: Boolean }
|
||||||
| WebSocketError ErrorType
|
| WebSocketError ErrorType
|
||||||
|
|
||||||
webSocketEmitter :: forall msg. WS.WebSocket -> JsonCodec msg -> HS.Emitter (WebSocketEvent msg)
|
webSocketEmitter :: WS.WebSocket -> HS.Emitter (WebSocketEvent WebSocketMessageType)
|
||||||
webSocketEmitter socket codec = do
|
webSocketEmitter socket = do
|
||||||
|
|
||||||
HS.makeEmitter \push -> do
|
HS.makeEmitter \push -> do
|
||||||
|
|
||||||
|
@ -66,17 +72,17 @@ webSocketEmitter socket codec = do
|
||||||
where
|
where
|
||||||
target = WS.toEventTarget socket
|
target = WS.toEventTarget socket
|
||||||
|
|
||||||
openEmitter :: HS.Emitter (WebSocketEvent msg)
|
openEmitter :: HS.Emitter (WebSocketEvent WebSocketMessageType)
|
||||||
openEmitter =
|
openEmitter =
|
||||||
HQE.eventListener WSET.onOpen target \_ ->
|
HQE.eventListener WSET.onOpen target \_ ->
|
||||||
Just WebSocketOpen
|
Just WebSocketOpen
|
||||||
|
|
||||||
errorEmitter :: HS.Emitter (WebSocketEvent msg)
|
errorEmitter :: HS.Emitter (WebSocketEvent WebSocketMessageType)
|
||||||
errorEmitter =
|
errorEmitter =
|
||||||
HQE.eventListener WSET.onError target \_ ->
|
HQE.eventListener WSET.onError target \_ ->
|
||||||
Just (WebSocketError UnknownWebSocketError)
|
Just (WebSocketError UnknownWebSocketError)
|
||||||
|
|
||||||
closeEmitter :: HS.Emitter (WebSocketEvent msg)
|
closeEmitter :: HS.Emitter (WebSocketEvent WebSocketMessageType)
|
||||||
closeEmitter =
|
closeEmitter =
|
||||||
HQE.eventListener WSET.onClose target \event ->
|
HQE.eventListener WSET.onClose target \event ->
|
||||||
WSCE.fromEvent event >>= \closeEvent ->
|
WSCE.fromEvent event >>= \closeEvent ->
|
||||||
|
@ -85,59 +91,35 @@ webSocketEmitter socket codec = do
|
||||||
, wasClean: WSCE.wasClean closeEvent
|
, wasClean: WSCE.wasClean closeEvent
|
||||||
}
|
}
|
||||||
|
|
||||||
messageEmitter :: HS.Emitter (WebSocketEvent msg)
|
messageEmitter :: HS.Emitter (WebSocketEvent WebSocketMessageType)
|
||||||
messageEmitter = HQE.eventListener WSET.onMessage target (WSME.fromEvent >=> decodeMessageEvent codec)
|
messageEmitter = HQE.eventListener WSET.onMessage target (WSME.fromEvent >=> decodeMessageEvent)
|
||||||
|
|
||||||
decodeMessageEvent :: forall msg. JsonCodec msg -> WSME.MessageEvent -> Maybe (WebSocketEvent msg)
|
decodeMessageEvent :: WSME.MessageEvent -> Maybe (WebSocketEvent WebSocketMessageType)
|
||||||
decodeMessageEvent codec = \msgEvent -> do
|
decodeMessageEvent = \msgEvent -> do
|
||||||
let
|
let
|
||||||
foreign' :: Foreign
|
foreign' :: Foreign
|
||||||
foreign' = WSME.data_ msgEvent
|
foreign' = WSME.data_ msgEvent
|
||||||
case runExcept (F.readString foreign') of
|
case foreignToArrayBuffer foreign' of
|
||||||
Left errList -> pure $ WebSocketError $ MessageJsonError (JsonForeignError errList)
|
Left errs -> pure $ WebSocketError $ UnknownError errs
|
||||||
Right string
|
Right arrayBuffer -> pure $ WebSocketMessage { message: arrayBuffer, origin: WSME.origin msgEvent, lastEventId: WSME.lastEventId msgEvent }
|
||||||
| String.contains (String.Pattern "sponsored by") string ->
|
|
||||||
pure $ WebSocketError $ MessageIsServerAdvertisement string
|
|
||||||
| otherwise ->
|
|
||||||
case AP.jsonParser string of
|
|
||||||
Left parseError -> pure $ WebSocketError $ MessageJsonError $ JsonParseError parseError
|
|
||||||
Right json -> case CA.decode codec json of
|
|
||||||
Left decodeError -> pure $ WebSocketError $ MessageJsonError $ JsonDecodeError decodeError
|
|
||||||
Right message ->
|
|
||||||
pure $ WebSocketMessage { message, origin: WSME.origin msgEvent, lastEventId: WSME.lastEventId msgEvent }
|
|
||||||
|
|
||||||
---------------------------
|
---------------------------
|
||||||
-- Errors
|
-- Errors
|
||||||
---------------------------
|
---------------------------
|
||||||
data ErrorType
|
data ErrorType
|
||||||
= MessageJsonError JsonError
|
= MessageIsServerAdvertisement String
|
||||||
| MessageIsServerAdvertisement String
|
| UnknownError String
|
||||||
| UnknownWebSocketError
|
| UnknownWebSocketError
|
||||||
|
|
||||||
data JsonError
|
|
||||||
= JsonForeignError (NonEmptyList F.ForeignError)
|
|
||||||
| JsonParseError String
|
|
||||||
| JsonDecodeError JsonDecodeError
|
|
||||||
|
|
||||||
renderError :: ErrorType -> String
|
renderError :: ErrorType -> String
|
||||||
renderError = case _ of
|
renderError = case _ of
|
||||||
MessageJsonError jsonErr ->
|
UnknownError str ->
|
||||||
renderJsonError jsonErr
|
"Unknown error: " <> str
|
||||||
MessageIsServerAdvertisement str ->
|
MessageIsServerAdvertisement str ->
|
||||||
"Received following advertisment from server: " <> str
|
"Received following advertisment from server: " <> str
|
||||||
UnknownWebSocketError ->
|
UnknownWebSocketError ->
|
||||||
"Unknown 'error' event has been fired by WebSocket event listener"
|
"Unknown 'error' event has been fired by WebSocket event listener"
|
||||||
|
|
||||||
renderJsonError :: JsonError -> String
|
|
||||||
renderJsonError = case _ of
|
|
||||||
JsonForeignError frgn ->
|
|
||||||
"JsonForeignError: " <> String.joinWith "; " (NEL.toUnfoldable $ map F.renderForeignError frgn)
|
|
||||||
JsonParseError str ->
|
|
||||||
"JsonParseError: " <> str
|
|
||||||
JsonDecodeError jde ->
|
|
||||||
"JsonDecodeError: " <> CA.printJsonDecodeError jde
|
|
||||||
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- Example `Main` module
|
-- Example `Main` module
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
@ -152,12 +134,7 @@ main = do
|
||||||
-- WebSocket message type
|
-- WebSocket message type
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
-- Not going to have anything elaborate in terms of actual websocket messages
|
type WebSocketMessageType = ArrayBuffer
|
||||||
-- for an echo server example.
|
|
||||||
type ExampleMessage = String
|
|
||||||
|
|
||||||
exampleMessageCodec :: JsonCodec ExampleMessage
|
|
||||||
exampleMessageCodec = CA.string
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- Example root component module
|
-- Example root component module
|
||||||
|
@ -171,7 +148,7 @@ data Action
|
||||||
| ConnectWebSocket
|
| ConnectWebSocket
|
||||||
| HandleInputUpdate String
|
| HandleInputUpdate String
|
||||||
| SendMessage Event
|
| SendMessage Event
|
||||||
| HandleWebSocket (WebSocketEvent ExampleMessage)
|
| HandleWebSocket (WebSocketEvent WebSocketMessageType)
|
||||||
|
|
||||||
type State =
|
type State =
|
||||||
{ messages :: Array String
|
{ messages :: Array String
|
||||||
|
@ -282,8 +259,9 @@ handleAction = case _ of
|
||||||
{ wsUrl } <- H.get
|
{ wsUrl } <- H.get
|
||||||
systemMessage ("Connecting to \"" <> wsUrl <> "\"...")
|
systemMessage ("Connecting to \"" <> wsUrl <> "\"...")
|
||||||
webSocket <- H.liftEffect $ WS.create wsUrl []
|
webSocket <- H.liftEffect $ WS.create wsUrl []
|
||||||
|
H.liftEffect $ WS.setBinaryType webSocket ArrayBuffer
|
||||||
H.modify_ _ { wsConnection = Just webSocket }
|
H.modify_ _ { wsConnection = Just webSocket }
|
||||||
void $ H.subscribe (HandleWebSocket <$> webSocketEmitter webSocket exampleMessageCodec)
|
void $ H.subscribe (HandleWebSocket <$> webSocketEmitter webSocket)
|
||||||
|
|
||||||
HandleInputUpdate text -> do
|
HandleInputUpdate text -> do
|
||||||
H.modify_ _ { inputText = text }
|
H.modify_ _ { inputText = text }
|
||||||
|
@ -320,20 +298,23 @@ handleAction = case _ of
|
||||||
H.liftEffect $ WS.close webSocket
|
H.liftEffect $ WS.close webSocket
|
||||||
systemMessageReset $ "You have requested to disconnect from the server"
|
systemMessageReset $ "You have requested to disconnect from the server"
|
||||||
otherMessage -> do
|
otherMessage -> do
|
||||||
H.liftEffect $ WS.sendString webSocket (AC.stringify $ CA.encode exampleMessageCodec otherMessage)
|
-- H.liftEffect $ WS.sendString webSocket (AC.stringify $ CA.encode exampleMessageCodec otherMessage)
|
||||||
|
-- TODO: send binary data.
|
||||||
|
H.liftEffect $ do
|
||||||
|
ab <- toIPC otherMessage
|
||||||
|
sendArrayBuffer webSocket ab
|
||||||
appendMessageReset $ "[😇] You: " <> otherMessage
|
appendMessageReset $ "[😇] You: " <> otherMessage
|
||||||
|
|
||||||
HandleWebSocket wsEvent ->
|
HandleWebSocket wsEvent ->
|
||||||
case wsEvent of
|
case wsEvent of
|
||||||
WebSocketMessage messageEvent -> do
|
WebSocketMessage messageEvent -> do
|
||||||
appendMessage $ "[😈] Server: " <> messageEvent.message
|
str <- H.liftEffect $ fromIPC messageEvent.message
|
||||||
|
appendMessage $ "[😈] Server sent: " <> str
|
||||||
|
|
||||||
WebSocketOpen -> do
|
WebSocketOpen -> do
|
||||||
{ wsUrl } <- H.get
|
{ wsUrl } <- H.get
|
||||||
systemMessage ("Successfully connected to WebSocket at \"" <> wsUrl <> "\"!🎉")
|
systemMessage ("Successfully connected to WebSocket at \"" <> wsUrl <> "\"!🎉")
|
||||||
|
|
||||||
|
|
||||||
WebSocketClose { code, reason, wasClean } -> do
|
WebSocketClose { code, reason, wasClean } -> do
|
||||||
systemMessage $ renderCloseMessage code wasClean reason
|
systemMessage $ renderCloseMessage code wasClean reason
|
||||||
maybeCurrentConnection <- H.gets _.wsConnection
|
maybeCurrentConnection <- H.gets _.wsConnection
|
||||||
|
@ -364,6 +345,9 @@ handleAction = case _ of
|
||||||
, "]"
|
, "]"
|
||||||
]
|
]
|
||||||
|
|
||||||
|
sendArrayBuffer :: WS.WebSocket -> ArrayBuffer -> Effect Unit
|
||||||
|
sendArrayBuffer = WS.sendArrayBuffer
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- Helpers for updating the array of messages sent/received
|
-- Helpers for updating the array of messages sent/received
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
@ -408,3 +392,17 @@ systemMessageReset msg = appendMessageReset ("[🤖] System: " <> msg)
|
||||||
-- A system message to use when a message cannot be sent.
|
-- A system message to use when a message cannot be sent.
|
||||||
unableToSend :: forall m. MonadState State m => String -> m Unit
|
unableToSend :: forall m. MonadState State m => String -> m Unit
|
||||||
unableToSend reason = systemMessage ("Unable to send. " <> reason)
|
unableToSend reason = systemMessage ("Unable to send. " <> reason)
|
||||||
|
|
||||||
|
foreignToArrayBuffer :: Foreign -> Either String ArrayBuffer
|
||||||
|
foreignToArrayBuffer
|
||||||
|
= lmap renderForeignErrors
|
||||||
|
<<< runExcept
|
||||||
|
<<< F.unsafeReadTagged "ArrayBuffer"
|
||||||
|
where
|
||||||
|
renderForeignErrors :: F.MultipleErrors -> String
|
||||||
|
renderForeignErrors =
|
||||||
|
String.joinWith "; " <<< A.fromFoldable <<< map F.renderForeignError
|
||||||
|
|
||||||
|
---- Get any Foreign value to either a String
|
||||||
|
--foreignToDataView :: Foreign -> Either String DataView
|
||||||
|
--foreignToDataView = map arrayBufferToDataView <<< foreignToArrayBuffer
|
||||||
|
|
Loading…
Reference in New Issue