diff --git a/makefile b/makefile new file mode 100644 index 0000000..b6eb294 --- /dev/null +++ b/makefile @@ -0,0 +1,23 @@ +all: build + +build: + npm run build + +bundle: + spago bundle-app + +serve: + npm run serve + +spagobuild: + spago build + +#HTTPD_ACCESS_LOGS ?= /tmp/access.log +#HTTPD_ADDR ?= 127.0.0.1 +#HTTPD_PORT ?= 35000 +#DIR ?= output +#serve: +# darkhttpd $(DIR) --addr $(HTTPD_ADDR) --port $(HTTPD_PORT) --log $(HTTPD_ACCESS_LOGS) + +# You can add your specific instructions there. +-include makefile.user diff --git a/spago.dhall b/spago.dhall index 695938b..737f2c0 100644 --- a/spago.dhall +++ b/spago.dhall @@ -1,5 +1,29 @@ { name = "halogen-project" -, dependencies = [ "console", "effect", "halogen", "prelude" ] +, dependencies = + [ "aff" + , "argonaut-core" + , "arraybuffer" + , "arraybuffer-builder" + , "arraybuffer-types" + , "arrays" + , "codec-argonaut" + , "console" + , "const" + , "effect" + , "either" + , "foreign" + , "halogen" + , "halogen-subscriptions" + , "lists" + , "maybe" + , "prelude" + , "strings" + , "transformers" + , "uint" + , "web-encoding" + , "web-events" + , "web-socket" + ] , packages = ./packages.dhall , sources = [ "src/**/*.purs", "test/**/*.purs" ] } diff --git a/src/App/IPC.purs b/src/App/IPC.purs new file mode 100644 index 0000000..8f91f6a --- /dev/null +++ b/src/App/IPC.purs @@ -0,0 +1,56 @@ +module App.IPC (toIPC, fromIPC) where + +import Prelude + +import Effect (Effect) +import Effect.Class (class MonadEffect, liftEffect) +import Effect.Class.Console as Console + +import Data.Maybe +import Data.UInt (UInt, fromInt, toInt) +import Data.Array (drop, cons) +import Data.ArrayBuffer.Types (DataView, ArrayBuffer(..)) +import Data.ArrayBuffer.Typed (buffer) +import Data.ArrayBuffer.ArrayBuffer as AB +import Data.ArrayBuffer.Builder (PutM, putArrayBuffer, execPut, putUint32be) + +import Data.String.CodeUnits as CU + +import Web.Encoding.TextEncoder (new, TextEncoder, encode) +import Web.Encoding.TextDecoder as TD + +import Data.Char (fromCharCode) + +import Data.ArrayBuffer.DataView as DV +import Effect.Unsafe + +putStringUtf8 :: forall m. MonadEffect m => String -> PutM m Unit +putStringUtf8 s = do + textEncoder <- liftEffect new + let stringbuf = buffer $ encode s textEncoder + -- Put a 32-bit big-endian length for the utf8 string, in bytes. + putUint32be $ fromInt $ AB.byteLength stringbuf + putArrayBuffer stringbuf + +toIPC :: String -> Effect ArrayBuffer +toIPC s = execPut $ putStringUtf8 s + +-- TODO: fix this implementation. Use an actual text decoder. +arraybufferToString :: ArrayBuffer -> Effect String +arraybufferToString arraybuffer + = case (AB.byteLength arraybuffer) of + 0 -> pure "" + _ -> do + maybeFirstByte <- DV.getUint8 (DV.whole arraybuffer) 0 + rest <- arraybufferToString $ AB.slice 1 (AB.byteLength arraybuffer) arraybuffer + pure $ (CU.singleton $ firstChar maybeFirstByte) <> rest + where + firstChar :: Maybe UInt -> Char + firstChar byte = fromMaybe '\n' (fromCharCode (toInt (fromMaybe (fromInt 10) byte))) + +dataviewToString :: DataView -> Effect String +dataviewToString dataview = arraybufferToString $ DV.buffer dataview + +-- TODO: make sure the String length is correct. +fromIPC :: ArrayBuffer -> Effect String +fromIPC ab = arraybufferToString (AB.slice 4 (AB.byteLength ab) ab) diff --git a/src/Main.purs b/src/Main.purs index 57971c8..080de35 100644 --- a/src/Main.purs +++ b/src/Main.purs @@ -2,12 +2,409 @@ module Main where import Prelude -import App.Button as Button +import Control.Monad.Except (runExcept) +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.Const (Const) +import Data.Either (Either(..)) +import Data.List.NonEmpty (NonEmptyList) +import Data.List.NonEmpty as NEL +import Data.Maybe (Maybe(..), isJust, isNothing, maybe) +import Data.String as String import Effect (Effect) -import Halogen.Aff as HA +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 + +-------------------------------------------------------------------------------- +-- 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 :: forall msg. WS.WebSocket -> JsonCodec msg -> HS.Emitter (WebSocketEvent msg) +webSocketEmitter socket codec = 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 msg) + openEmitter = + HQE.eventListener WSET.onOpen target \_ -> + Just WebSocketOpen + + errorEmitter :: HS.Emitter (WebSocketEvent msg) + errorEmitter = + HQE.eventListener WSET.onError target \_ -> + Just (WebSocketError UnknownWebSocketError) + + closeEmitter :: HS.Emitter (WebSocketEvent msg) + 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 msg) + messageEmitter = HQE.eventListener WSET.onMessage target (WSME.fromEvent >=> decodeMessageEvent codec) + +decodeMessageEvent :: forall msg. JsonCodec msg -> WSME.MessageEvent -> Maybe (WebSocketEvent msg) +decodeMessageEvent codec = \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 } + +--------------------------- +-- Errors +--------------------------- +data ErrorType + = MessageJsonError JsonError + | MessageIsServerAdvertisement String + | UnknownWebSocketError + +data JsonError + = JsonForeignError (NonEmptyList F.ForeignError) + | JsonParseError String + | JsonDecodeError JsonDecodeError + +renderError :: ErrorType -> String +renderError = case _ of + MessageJsonError jsonErr -> + renderJsonError jsonErr + 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 +-------------------------------------------------------------------------------- main :: Effect Unit -main = HA.runHalogenAff do - body <- HA.awaitBody - runUI Button.component unit body +main = do + HA.runHalogenAff do + body <- HA.awaitBody + let url = "ws://localhost:8080" + runUI rootComponent url body + +-------------------------------------------------------------------------------- +-- 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 + +-------------------------------------------------------------------------------- +-- Example root component module +-------------------------------------------------------------------------------- +type Query = Const Void +type Input = String +type Output = Void + +data Action + = Initialize + | ConnectWebSocket + | HandleInputUpdate String + | SendMessage Event + | HandleWebSocket (WebSocketEvent ExampleMessage) + +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 + + ConnectWebSocket -> do + { wsUrl } <- H.get + systemMessage ("Connecting to \"" <> wsUrl <> "\"...") + webSocket <- H.liftEffect $ WS.create wsUrl [] + H.modify_ _ { wsConnection = Just webSocket } + void $ H.subscribe (HandleWebSocket <$> webSocketEmitter webSocket exampleMessageCodec) + + 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 $ WS.sendString webSocket (AC.stringify $ CA.encode exampleMessageCodec otherMessage) + appendMessageReset $ "[😇] You: " <> otherMessage + + HandleWebSocket wsEvent -> + case wsEvent of + WebSocketMessage messageEvent -> do + appendMessage $ "[😈] Server: " <> messageEvent.message + + + 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" + , "]" + ] + +-------------------------------------------------------------------------------- +-- 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)