diff --git a/makefile b/makefile index b6eb294..d91346c 100644 --- a/makefile +++ b/makefile @@ -6,6 +6,9 @@ build: bundle: spago bundle-app +repl: + spago repl + serve: npm run serve diff --git a/src/Main.purs b/src/Main.purs index 080de35..eed05b7 100644 --- a/src/Main.purs +++ b/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