Starting point.

This commit is contained in:
Philippe Pittoli 2023-05-19 01:06:39 +02:00
parent 92ff305c61
commit 20207e7e73
4 changed files with 506 additions and 6 deletions

23
makefile Normal file
View File

@ -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

View File

@ -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" ]
}

56
src/App/IPC.purs Normal file
View File

@ -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)

View File

@ -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)