diff --git a/src/Main.purs b/src/Main.purs index df95dc0..c22b7da 100644 --- a/src/Main.purs +++ b/src/Main.purs @@ -1,409 +1,12 @@ module Main 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.Aff as HA 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 --------------------------------------------------------------------------------- +import App.Container as Container main :: Effect Unit main = HA.runHalogenAff do body <- HA.awaitBody - let url = "ws://localhost:8080" - runUI rootComponent url body - -- runUI Container.component unit body - --------------------------------------------------------------------------------- --- WebSocket message type --------------------------------------------------------------------------------- - -type WebSocketMessageType = ArrayBuffer - --------------------------------------------------------------------------------- --- Root component module --------------------------------------------------------------------------------- - -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 - } - -rootComponent :: forall m. MonadAff m => H.Component Query Input Output m -rootComponent = - 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 + runUI Container.component unit body