Remove useless JSON stuff, replace it with ArrayBuffer serialization.

This commit is contained in:
Philippe Pittoli 2023-05-19 15:45:41 +02:00
parent 20207e7e73
commit e1d49f1048
2 changed files with 55 additions and 54 deletions

View File

@ -6,6 +6,9 @@ build:
bundle:
spago bundle-app
repl:
spago repl
serve:
npm run serve

View File

@ -7,8 +7,9 @@ import Control.Monad.State (class MonadState)
import Data.Argonaut.Core as AC
import Data.Argonaut.Parser as AP
import Data.Array as A
import Data.Codec.Argonaut (JsonCodec, JsonDecodeError)
import Data.Codec.Argonaut as CA
import Data.Bifunctor (lmap)
-- import Data.Codec.Argonaut (JsonCodec, JsonDecodeError)
-- import Data.Codec.Argonaut as CA
import Data.Const (Const)
import Data.Either (Either(..))
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.WebSocket as WS
import Data.ArrayBuffer.Types (ArrayBuffer)
import Web.Socket.BinaryType (BinaryType(ArrayBuffer))
import App.IPC (toIPC, fromIPC)
--------------------------------------------------------------------------------
-- WebSocketEvent type
@ -47,8 +53,8 @@ data WebSocketEvent msg
| WebSocketClose { code :: Int, reason :: String, wasClean :: Boolean }
| WebSocketError ErrorType
webSocketEmitter :: forall msg. WS.WebSocket -> JsonCodec msg -> HS.Emitter (WebSocketEvent msg)
webSocketEmitter socket codec = do
webSocketEmitter :: WS.WebSocket -> HS.Emitter (WebSocketEvent WebSocketMessageType)
webSocketEmitter socket = do
HS.makeEmitter \push -> do
@ -66,17 +72,17 @@ webSocketEmitter socket codec = do
where
target = WS.toEventTarget socket
openEmitter :: HS.Emitter (WebSocketEvent msg)
openEmitter :: HS.Emitter (WebSocketEvent WebSocketMessageType)
openEmitter =
HQE.eventListener WSET.onOpen target \_ ->
Just WebSocketOpen
errorEmitter :: HS.Emitter (WebSocketEvent msg)
errorEmitter :: HS.Emitter (WebSocketEvent WebSocketMessageType)
errorEmitter =
HQE.eventListener WSET.onError target \_ ->
Just (WebSocketError UnknownWebSocketError)
closeEmitter :: HS.Emitter (WebSocketEvent msg)
closeEmitter :: HS.Emitter (WebSocketEvent WebSocketMessageType)
closeEmitter =
HQE.eventListener WSET.onClose target \event ->
WSCE.fromEvent event >>= \closeEvent ->
@ -85,59 +91,35 @@ webSocketEmitter socket codec = do
, wasClean: WSCE.wasClean closeEvent
}
messageEmitter :: HS.Emitter (WebSocketEvent msg)
messageEmitter = HQE.eventListener WSET.onMessage target (WSME.fromEvent >=> decodeMessageEvent codec)
messageEmitter :: HS.Emitter (WebSocketEvent WebSocketMessageType)
messageEmitter = HQE.eventListener WSET.onMessage target (WSME.fromEvent >=> decodeMessageEvent)
decodeMessageEvent :: forall msg. JsonCodec msg -> WSME.MessageEvent -> Maybe (WebSocketEvent msg)
decodeMessageEvent codec = \msgEvent -> do
decodeMessageEvent :: WSME.MessageEvent -> Maybe (WebSocketEvent WebSocketMessageType)
decodeMessageEvent = \msgEvent -> do
let
foreign' :: Foreign
foreign' = WSME.data_ msgEvent
case runExcept (F.readString foreign') of
Left errList -> pure $ WebSocketError $ MessageJsonError (JsonForeignError errList)
Right string
| 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 }
case foreignToArrayBuffer foreign' of
Left errs -> pure $ WebSocketError $ UnknownError errs
Right arrayBuffer -> pure $ WebSocketMessage { message: arrayBuffer, origin: WSME.origin msgEvent, lastEventId: WSME.lastEventId msgEvent }
---------------------------
-- Errors
---------------------------
data ErrorType
= MessageJsonError JsonError
| MessageIsServerAdvertisement String
= MessageIsServerAdvertisement String
| UnknownError String
| UnknownWebSocketError
data JsonError
= JsonForeignError (NonEmptyList F.ForeignError)
| JsonParseError String
| JsonDecodeError JsonDecodeError
renderError :: ErrorType -> String
renderError = case _ of
MessageJsonError jsonErr ->
renderJsonError jsonErr
UnknownError str ->
"Unknown error: " <> str
MessageIsServerAdvertisement str ->
"Received following advertisment from server: " <> str
UnknownWebSocketError ->
"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
--------------------------------------------------------------------------------
@ -152,12 +134,7 @@ main = do
-- WebSocket message type
--------------------------------------------------------------------------------
-- Not going to have anything elaborate in terms of actual websocket messages
-- for an echo server example.
type ExampleMessage = String
exampleMessageCodec :: JsonCodec ExampleMessage
exampleMessageCodec = CA.string
type WebSocketMessageType = ArrayBuffer
--------------------------------------------------------------------------------
-- Example root component module
@ -171,7 +148,7 @@ data Action
| ConnectWebSocket
| HandleInputUpdate String
| SendMessage Event
| HandleWebSocket (WebSocketEvent ExampleMessage)
| HandleWebSocket (WebSocketEvent WebSocketMessageType)
type State =
{ messages :: Array String
@ -282,8 +259,9 @@ handleAction = case _ of
{ wsUrl } <- H.get
systemMessage ("Connecting to \"" <> wsUrl <> "\"...")
webSocket <- H.liftEffect $ WS.create wsUrl []
H.liftEffect $ WS.setBinaryType webSocket ArrayBuffer
H.modify_ _ { wsConnection = Just webSocket }
void $ H.subscribe (HandleWebSocket <$> webSocketEmitter webSocket exampleMessageCodec)
void $ H.subscribe (HandleWebSocket <$> webSocketEmitter webSocket)
HandleInputUpdate text -> do
H.modify_ _ { inputText = text }
@ -320,20 +298,23 @@ handleAction = case _ of
H.liftEffect $ WS.close webSocket
systemMessageReset $ "You have requested to disconnect from the server"
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
HandleWebSocket wsEvent ->
case wsEvent of
WebSocketMessage messageEvent -> do
appendMessage $ "[😈] Server: " <> messageEvent.message
str <- H.liftEffect $ fromIPC messageEvent.message
appendMessage $ "[😈] Server sent: " <> str
WebSocketOpen -> do
{ wsUrl } <- H.get
systemMessage ("Successfully connected to WebSocket at \"" <> wsUrl <> "\"!🎉")
WebSocketClose { code, reason, wasClean } -> do
systemMessage $ renderCloseMessage code wasClean reason
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
--------------------------------------------------------------------------------
@ -408,3 +392,17 @@ systemMessageReset msg = appendMessageReset ("[🤖] System: " <> msg)
-- A system message to use when a message cannot be sent.
unableToSend :: forall m. MonadState State m => String -> m Unit
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