Starting point.
parent
92ff305c61
commit
20207e7e73
|
|
@ -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
|
||||
26
spago.dhall
26
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" ]
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
405
src/Main.purs
405
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
|
||||
main = do
|
||||
HA.runHalogenAff do
|
||||
body <- HA.awaitBody
|
||||
runUI Button.component unit body
|
||||
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)
|
||||
|
|
|
|||
Loading…
Reference in New Issue