module App.OriginalInterface where import Prelude import Control.Monad.Except (runExcept) import Control.Monad.State (class MonadState) import Data.Array as A 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.Maybe (Maybe(..), isJust, isNothing, maybe) import Data.String as String import Effect (Effect) import Effect.Aff.Class (class MonadAff) import Foreign (Foreign) import Foreign as F import Halogen as H import Halogen.Aff (awaitBody, runHalogenAff) as HA import Halogen.HTML as HH import Halogen.HTML.Events as HE import Halogen.HTML.Properties as HP import Halogen.Query.Event as HQE import Halogen.Subscription as HS import Halogen.VDom.Driver (runUI) import Web.Event.Event (Event) import Web.Event.Event as Event import Web.Socket.Event.CloseEvent as WSCE import Web.Socket.Event.EventTypes as WSET 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 -------------------------------------------------------------------------------- data WebSocketEvent :: Type -> Type data WebSocketEvent msg = WebSocketMessage { message :: msg, origin :: String, lastEventId :: String } | WebSocketOpen | WebSocketClose { code :: Int, reason :: String, wasClean :: Boolean } | WebSocketError ErrorType webSocketEmitter :: WS.WebSocket -> HS.Emitter (WebSocketEvent WebSocketMessageType) webSocketEmitter socket = do HS.makeEmitter \push -> do openId <- HS.subscribe openEmitter push errorId <- HS.subscribe errorEmitter push closeId <- HS.subscribe closeEmitter push messageId <- HS.subscribe messageEmitter push pure do HS.unsubscribe openId HS.unsubscribe errorId HS.unsubscribe closeId HS.unsubscribe messageId where target = WS.toEventTarget socket openEmitter :: HS.Emitter (WebSocketEvent WebSocketMessageType) openEmitter = HQE.eventListener WSET.onOpen target \_ -> Just WebSocketOpen errorEmitter :: HS.Emitter (WebSocketEvent WebSocketMessageType) errorEmitter = HQE.eventListener WSET.onError target \_ -> Just (WebSocketError UnknownWebSocketError) closeEmitter :: HS.Emitter (WebSocketEvent WebSocketMessageType) closeEmitter = HQE.eventListener WSET.onClose target \event -> WSCE.fromEvent event >>= \closeEvent -> Just $ WebSocketClose { code: WSCE.code closeEvent , reason: WSCE.reason closeEvent , wasClean: WSCE.wasClean closeEvent } messageEmitter :: HS.Emitter (WebSocketEvent WebSocketMessageType) messageEmitter = HQE.eventListener WSET.onMessage target (WSME.fromEvent >=> decodeMessageEvent) decodeMessageEvent :: WSME.MessageEvent -> Maybe (WebSocketEvent WebSocketMessageType) decodeMessageEvent = \msgEvent -> do let foreign' :: Foreign foreign' = WSME.data_ 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 = MessageIsServerAdvertisement String | UnknownError String | UnknownWebSocketError renderError :: ErrorType -> String renderError = case _ of UnknownError str -> "Unknown error: " <> str MessageIsServerAdvertisement str -> "Received following advertisment from server: " <> str UnknownWebSocketError -> "Unknown 'error' event has been fired by WebSocket event listener" -------------------------------------------------------------------------------- -- `Main` function -------------------------------------------------------------------------------- main :: Effect Unit main = HA.runHalogenAff do body <- HA.awaitBody let url = "ws://localhost:8080" runUI component url body -- runUI Container.component unit body -------------------------------------------------------------------------------- -- WebSocket message type -------------------------------------------------------------------------------- type WebSocketMessageType = ArrayBuffer -------------------------------------------------------------------------------- -- Root component module -------------------------------------------------------------------------------- type Slot = H.Slot Query Void type Query :: forall k. k -> Type type Query = Const Void type Input = String type Output = Void data Action = Initialize | WebSocketParseError String | ConnectWebSocket | HandleInputUpdate String | SendMessage Event | HandleWebSocket (WebSocketEvent WebSocketMessageType) type State = { messages :: Array String , messageHistoryLength :: Int , inputText :: String , wsUrl :: String , wsConnection :: Maybe WS.WebSocket , canReconnect :: Boolean } component :: forall m. MonadAff m => H.Component Query Input Output m component = H.mkComponent { initialState , render , eval: H.mkEval $ H.defaultEval { initialize = Just Initialize , handleAction = handleAction } } initialState :: Input -> State initialState input = { messages: [] , messageHistoryLength: 10 , inputText: "" , wsUrl: input , wsConnection: Nothing , canReconnect: false } wrapperStyle :: String wrapperStyle = """ display: block; flex-direction: column; justify-content: space-between; height: calc(100vh - 30px); background: #282c34; color: #e06c75; font-family: 'Consolas'; padding: 5px 20px 5px 20px; """ render :: forall m. State -> H.ComponentHTML Action () m render { messages, inputText, wsConnection, canReconnect, messageHistoryLength } = HH.div [ HP.style wrapperStyle ] [ HH.h2_ [ HH.text "WebSocket example for PureScript Halogen" ] , HH.form [ HE.onSubmit SendMessage ] [ HH.ul_ $ map (\msg -> HH.li_ [ HH.text msg ]) messages , HH.p_ [ HH.div_ [ HH.input [ HP.style "padding: 0.5rem 0.75rem; margin-bottom: 0.25rem;" , HP.type_ HP.InputText , HP.value inputText , HE.onValueInput HandleInputUpdate , maybe (HP.disabled true) (\_ -> HP.enabled true) wsConnection ] ] , HH.div_ [ HH.button [ HP.style "padding: 0.5rem 1.25rem;" , HP.type_ HP.ButtonSubmit , maybe (HP.disabled true) (\_ -> HP.enabled true) wsConnection ] [ HH.text "Send Message to Server" ] ] ] , renderMaxHistoryLength messageHistoryLength , renderReconnectButton (isNothing wsConnection && canReconnect) ] ] where renderFootnote :: String -> H.ComponentHTML Action () m renderFootnote txt = HH.div [ HP.style "margin-bottom: 0.125rem; color: grey;" ] [ HH.small_ [ HH.text txt ] ] renderMaxHistoryLength :: Int -> H.ComponentHTML Action () m renderMaxHistoryLength len = renderFootnote ("NOTE: Maximum chat history length is " <> show len <> " messages") renderReconnectButton :: Boolean -> H.ComponentHTML Action () m renderReconnectButton cond = if cond then HH.p_ [ HH.button [ HP.type_ HP.ButtonButton , HE.onClick \_ -> ConnectWebSocket ] [ HH.text "Reconnect?" ] ] else HH.p_ [ renderFootnote "NOTE: A 'Reconnect?' button will appear if the connection drops" , renderFootnote "NOTE: You can type /disconnect to manually disconnect" ] handleAction :: forall m. MonadAff m => Action -> H.HalogenM State Action () Output m Unit handleAction = case _ of Initialize -> handleAction ConnectWebSocket WebSocketParseError error -> systemMessage $ renderError (UnknownError error) ConnectWebSocket -> do { 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) HandleInputUpdate text -> do H.modify_ _ { inputText = text } SendMessage ev -> do H.liftEffect $ Event.preventDefault ev { wsConnection, inputText } <- H.get case wsConnection, inputText of Nothing, _ -> unableToSend "Not connected to server." Just _ , "" -> unableToSend "Cannot send an empty message" Just webSocket, outgoingMessage -> do H.liftEffect (WS.readyState webSocket) >>= case _ of Connecting -> unableToSend "Still connecting to server." Closing -> unableToSend "Connection to server is closing." Closed -> do unableToSend "Connection to server has been closed." maybeCurrentConnection <- H.gets _.wsConnection when (isJust maybeCurrentConnection) do H.modify_ _ { wsConnection = Nothing, canReconnect = true } Open -> do case outgoingMessage of "/disconnect" -> do H.liftEffect $ WS.close webSocket systemMessageReset $ "You have requested to disconnect from the server" otherMessage -> do H.liftEffect $ do ab <- toIPC otherMessage sendArrayBuffer webSocket ab appendMessageReset $ "[😇] You: " <> otherMessage HandleWebSocket wsEvent -> case wsEvent of WebSocketMessage messageEvent -> do receivedMessage <- H.liftEffect $ fromIPC messageEvent.message case receivedMessage of Left parseError -> do handleAction $ WebSocketParseError $ show parseError Right string -> do appendMessage $ "[😈] Server: " <> string 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 when (isJust maybeCurrentConnection) do H.modify_ _ { wsConnection = Nothing, canReconnect = true } WebSocketError errorType -> systemMessage $ renderError errorType where renderCloseMessage :: Int -> Boolean -> String -> String renderCloseMessage code wasClean = case _ of "" -> baseCloseMessage reason -> baseCloseMessage <> "Reason: " <> reason where baseCloseMessage :: String baseCloseMessage = String.joinWith " " [ "Connection to WebSocket closed" , "[ CODE:" , show code , "|" , if wasClean then "CLEAN" else "DIRTY" , "]" ] sendArrayBuffer :: WS.WebSocket -> ArrayBuffer -> Effect Unit sendArrayBuffer = WS.sendArrayBuffer -------------------------------------------------------------------------------- -- Helpers for updating the array of messages sent/received -------------------------------------------------------------------------------- -- Append a new message to the chat history, with a boolean that allows you to -- clear the text input field or not. The number of displayed `messages` in the -- chat history (including system) is controlled by the `messageHistoryLength` -- field in the component `State`. appendMessageGeneric :: forall m. MonadState State m => Boolean -> String -> m Unit appendMessageGeneric clearField msg = do histSize <- H.gets _.messageHistoryLength if clearField then H.modify_ \st -> st { messages = appendSingle histSize msg st.messages, inputText = "" } else H.modify_ \st -> st { messages = appendSingle histSize msg st.messages } where -- Limits the nnumber of recent messages to `maxHist` appendSingle :: Int -> String -> Array String -> Array String appendSingle maxHist x xs | A.length xs < maxHist = xs `A.snoc` x | otherwise = (A.takeEnd (maxHist-1) xs) `A.snoc` x -- Append a new message to the chat history, while not clearing -- the user input field appendMessage :: forall m. MonadState State m => String -> m Unit appendMessage = appendMessageGeneric false -- Append a new message to the chat history and also clear -- the user input field appendMessageReset :: forall m. MonadState State m => String -> m Unit appendMessageReset = appendMessageGeneric true -- Append a system message to the chat log. systemMessage :: forall m. MonadState State m => String -> m Unit systemMessage msg = appendMessage ("[🤖] System: " <> msg) -- As above, but also clears the user input field. e.g. in -- the case of a "/disconnect" command systemMessageReset :: forall m. MonadState State m => String -> m Unit 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