Remove useless JSON stuff, replace it with ArrayBuffer serialization.
parent
20207e7e73
commit
e1d49f1048
3
makefile
3
makefile
|
|
@ -6,6 +6,9 @@ build:
|
|||
bundle:
|
||||
spago bundle-app
|
||||
|
||||
repl:
|
||||
spago repl
|
||||
|
||||
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.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
|
||||
|
|
|
|||
Loading…
Reference in New Issue