karchnu
/
halogen-websocket-ipc-playzone
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Put websocket info in a dedicated record.

beta
Philippe Pittoli 2023-07-03 04:04:14 +02:00
parent 15e407972a
commit e0fc55e5ca
2 changed files with 69 additions and 65 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

56
src/App/AuthenticationDaemonAdminInterface.purs
View File

@ -69,16 +69,19 @@ data Action
type StateAddUserForm = { login :: String, admin :: Boolean, email :: String, pass :: String } type StateAddUserForm = { login :: String, admin :: Boolean, email :: String, pass :: String }
type WSInfo
= { url :: String
, connection :: Maybe WS.WebSocket
, reconnect :: Boolean
}
type State = type State =
{ messages :: Array String { messages :: Array String
, messageHistoryLength :: Int , messageHistoryLength :: Int
, addUserForm :: StateAddUserForm , addUserForm :: StateAddUserForm
-- TODO: put network stuff in a record. , wsInfo :: WSInfo
, wsUrl :: String
, wsConnection :: Maybe WS.WebSocket
, canReconnect :: Boolean
} }
component :: forall m. MonadAff m => H.Component Query Input Output m component :: forall m. MonadAff m => H.Component Query Input Output m
@ -100,23 +103,22 @@ initialState input =
, addUserForm: { login: "", admin: false, email: "", pass: "" } , addUserForm: { login: "", admin: false, email: "", pass: "" }
-- TODO: put network stuff in a record. , wsInfo: { url: input
, wsUrl: input , connection: Nothing
, wsConnection: Nothing , reconnect: false
, canReconnect: false }
} }
render :: forall m. State -> H.ComponentHTML Action () m render :: forall m. State -> H.ComponentHTML Action () m
render { render {
messages, messages,
wsConnection, wsInfo,
canReconnect,
addUserForm } addUserForm }
= HH.div_ = HH.div_
[ Bulma.columns_ [ Bulma.column_ adduser_form ] [ Bulma.columns_ [ Bulma.column_ adduser_form ]
, render_messages , render_messages
--, renderMaxHistoryLength messageHistoryLength --, renderMaxHistoryLength messageHistoryLength
, renderReconnectButton (isNothing wsConnection && canReconnect) , renderReconnectButton (isNothing wsInfo.connection && wsInfo.reconnect)
] ]
where where
@ -125,7 +127,7 @@ render {
, render_adduser_form , render_adduser_form
] ]
should_be_disabled = (maybe (HP.disabled true) (\_ -> HP.enabled true) wsConnection) should_be_disabled = (maybe (HP.disabled true) (\_ -> HP.enabled true) wsInfo.connection)
render_adduser_form = HH.form render_adduser_form = HH.form
[ HE.onSubmit AddUserAttempt ] [ HE.onSubmit AddUserAttempt ]
@ -154,7 +156,7 @@ render {
[ HH.button [ HH.button
[ HP.style "padding: 0.5rem 1.25rem;" [ HP.style "padding: 0.5rem 1.25rem;"
, HP.type_ HP.ButtonSubmit , HP.type_ HP.ButtonSubmit
, maybe (HP.disabled true) (\_ -> HP.enabled true) wsConnection , maybe (HP.disabled true) (\_ -> HP.enabled true) wsInfo.connection
] ]
[ HH.text "Send Message to Server" ] [ HH.text "Send Message to Server" ]
] ]
@ -188,9 +190,9 @@ handleAction = case _ of
handleAction ConnectWebSocket handleAction ConnectWebSocket
-- Finalize -> do -- Finalize -> do
-- { wsConnection } <- H.get -- { wsInfo } <- H.get
-- systemMessage "Finalize" -- systemMessage "Finalize"
-- case wsConnection of -- case wsInfo.connection of
-- Nothing -> systemMessage "No socket? How is that even possible?" -- Nothing -> systemMessage "No socket? How is that even possible?"
-- Just socket -> H.liftEffect $ WS.close socket -- Just socket -> H.liftEffect $ WS.close socket
@ -198,11 +200,11 @@ handleAction = case _ of
systemMessage $ renderError (UnknownError error) systemMessage $ renderError (UnknownError error)
ConnectWebSocket -> do ConnectWebSocket -> do
{ wsUrl } <- H.get { wsInfo } <- H.get
systemMessage ("Connecting to \"" <> wsUrl <> "\"...") systemMessage ("Connecting to \"" <> wsInfo.url <> "\"...")
webSocket <- H.liftEffect $ WS.create wsUrl [] webSocket <- H.liftEffect $ WS.create wsInfo.url []
H.liftEffect $ WS.setBinaryType webSocket ArrayBuffer H.liftEffect $ WS.setBinaryType webSocket ArrayBuffer
H.modify_ _ { wsConnection = Just webSocket } H.modify_ _ { wsInfo { connection = Just webSocket } }
void $ H.subscribe (HandleWebSocket <$> webSocketEmitter webSocket) void $ H.subscribe (HandleWebSocket <$> webSocketEmitter webSocket)
HandleAddUserInput adduserinp -> do HandleAddUserInput adduserinp -> do
@ -216,12 +218,12 @@ handleAction = case _ of
AddUserAttempt ev -> do AddUserAttempt ev -> do
H.liftEffect $ Event.preventDefault ev H.liftEffect $ Event.preventDefault ev
{ wsConnection, addUserForm } <- H.get { wsInfo, addUserForm } <- H.get
let login = addUserForm.login let login = addUserForm.login
email = addUserForm.email email = addUserForm.email
pass = addUserForm.pass pass = addUserForm.pass
case wsConnection, login, email, pass of case wsInfo.connection, login, email, pass of
Nothing, _, _, _ -> Nothing, _, _, _ ->
unableToSend "Not connected to server." unableToSend "Not connected to server."
@ -244,9 +246,9 @@ handleAction = case _ of
Closed -> do Closed -> do
unableToSend "Connection to server has been closed." unableToSend "Connection to server has been closed."
maybeCurrentConnection <- H.gets _.wsConnection maybeCurrentConnection <- H.gets _.wsInfo.connection
when (isJust maybeCurrentConnection) do when (isJust maybeCurrentConnection) do
H.modify_ _ { wsConnection = Nothing, canReconnect = true } H.modify_ _ { wsInfo { connection = Nothing, reconnect = true } }
Open -> do Open -> do
H.liftEffect $ do H.liftEffect $ do
@ -284,14 +286,14 @@ handleAction = case _ of
appendMessage $ "[😈] Failed! Authentication server didn't send a valid message." appendMessage $ "[😈] Failed! Authentication server didn't send a valid message."
WebSocketOpen -> do WebSocketOpen -> do
{ wsUrl } <- H.get { wsInfo } <- H.get
systemMessage ("Successfully connected to WebSocket at \"" <> wsUrl <> "\"!🎉") systemMessage ("Successfully connected to WebSocket at \"" <> wsInfo.url <> "\"!🎉")
WebSocketClose { code, reason, wasClean } -> do WebSocketClose { code, reason, wasClean } -> do
systemMessage $ renderCloseMessage code wasClean reason systemMessage $ renderCloseMessage code wasClean reason
maybeCurrentConnection <- H.gets _.wsConnection maybeCurrentConnection <- H.gets _.wsInfo.connection
when (isJust maybeCurrentConnection) do when (isJust maybeCurrentConnection) do
H.modify_ _ { wsConnection = Nothing, canReconnect = true } H.modify_ _ { wsInfo { connection = Nothing, reconnect = true } }
WebSocketError errorType -> WebSocketError errorType ->
systemMessage $ renderError errorType systemMessage $ renderError errorType

78
src/App/AuthenticationForm.purs
View File

@ -68,17 +68,20 @@ data Action
type StateAuthenticationForm = { login :: String, pass :: String } type StateAuthenticationForm = { login :: String, pass :: String }
type StateRegistrationForm = { login :: String, email :: String, pass :: String } type StateRegistrationForm = { login :: String, email :: String, pass :: String }
type WSInfo
= { url :: String
, connection :: Maybe WS.WebSocket
, reconnect :: Boolean
}
type State = type State =
{ messages :: Array String { messages :: Array String
, messageHistoryLength :: Int , messageHistoryLength :: Int
, authenticationForm :: StateAuthenticationForm , authenticationForm :: StateAuthenticationForm
, registrationForm :: StateRegistrationForm , registrationForm :: StateRegistrationForm
-- TODO: put network stuff in a record. , wsInfo :: WSInfo
, wsUrl :: String
, wsConnection :: Maybe WS.WebSocket
, canReconnect :: Boolean
} }
component :: forall m. MonadAff m => H.Component Query Input Output m component :: forall m. MonadAff m => H.Component Query Input Output m
@ -101,24 +104,23 @@ initialState input =
, authenticationForm: { login: "", pass: "" } , authenticationForm: { login: "", pass: "" }
, registrationForm: { login: "", email: "", pass: "" } , registrationForm: { login: "", email: "", pass: "" }
-- TODO: put network stuff in a record. , wsInfo: { url: input
, wsUrl: input , connection: Nothing
, wsConnection: Nothing , reconnect: false
, canReconnect: false }
} }
render :: forall m. State -> H.ComponentHTML Action () m render :: forall m. State -> H.ComponentHTML Action () m
render { render {
messages, messages,
wsConnection, wsInfo,
canReconnect,
authenticationForm, authenticationForm,
registrationForm } registrationForm }
= HH.div_ = HH.div_
[ Bulma.columns_ [ Bulma.column_ auth_form, Bulma.column_ register_form ] [ Bulma.columns_ [ Bulma.column_ auth_form, Bulma.column_ register_form ]
, render_messages , render_messages
, renderReconnectButton (isNothing wsConnection && canReconnect) , renderReconnectButton (isNothing wsInfo.connection && wsInfo.reconnect)
] ]
where where
@ -138,16 +140,16 @@ render {
(HandleAuthenticationInput <<< AUTH_INP_login) -- action (HandleAuthenticationInput <<< AUTH_INP_login) -- action
authenticationForm.login -- value authenticationForm.login -- value
true -- validity (TODO) true -- validity (TODO)
(maybe (HP.disabled true) (\_ -> HP.enabled true) wsConnection) -- condition (maybe (HP.disabled true) (\_ -> HP.enabled true) wsInfo.connection) -- condition
, Bulma.box_password "Password" "password" -- title, placeholder , Bulma.box_password "Password" "password" -- title, placeholder
(HandleAuthenticationInput <<< AUTH_INP_pass) -- action (HandleAuthenticationInput <<< AUTH_INP_pass) -- action
authenticationForm.pass -- value authenticationForm.pass -- value
true -- validity (TODO) true -- validity (TODO)
(maybe (HP.disabled true) (\_ -> HP.enabled true) wsConnection) -- condition (maybe (HP.disabled true) (\_ -> HP.enabled true) wsInfo.connection) -- condition
, HH.button , HH.button
[ HP.style "padding: 0.5rem 1.25rem;" [ HP.style "padding: 0.5rem 1.25rem;"
, HP.type_ HP.ButtonSubmit , HP.type_ HP.ButtonSubmit
, maybe (HP.disabled true) (\_ -> HP.enabled true) wsConnection , maybe (HP.disabled true) (\_ -> HP.enabled true) wsInfo.connection
] ]
[ HH.text "Send Message to Server" ] [ HH.text "Send Message to Server" ]
] ]
@ -158,22 +160,22 @@ render {
(HandleRegisterInput <<< REG_INP_login) -- action (HandleRegisterInput <<< REG_INP_login) -- action
registrationForm.login -- value registrationForm.login -- value
true -- validity (TODO) true -- validity (TODO)
(maybe (HP.disabled true) (\_ -> HP.enabled true) wsConnection) -- condition (maybe (HP.disabled true) (\_ -> HP.enabled true) wsInfo.connection) -- condition
, Bulma.box_input "Email" "email@example.com" -- title, placeholder , Bulma.box_input "Email" "email@example.com" -- title, placeholder
(HandleRegisterInput <<< REG_INP_email) -- action (HandleRegisterInput <<< REG_INP_email) -- action
registrationForm.email -- value registrationForm.email -- value
true -- validity (TODO) true -- validity (TODO)
(maybe (HP.disabled true) (\_ -> HP.enabled true) wsConnection) -- condition (maybe (HP.disabled true) (\_ -> HP.enabled true) wsInfo.connection) -- condition
, Bulma.box_password "Password" "password" -- title, placeholder , Bulma.box_password "Password" "password" -- title, placeholder
(HandleRegisterInput <<< REG_INP_pass) -- action (HandleRegisterInput <<< REG_INP_pass) -- action
registrationForm.pass -- value registrationForm.pass -- value
true -- validity (TODO) true -- validity (TODO)
(maybe (HP.disabled true) (\_ -> HP.enabled true) wsConnection) -- condition (maybe (HP.disabled true) (\_ -> HP.enabled true) wsInfo.connection) -- condition
, HH.div_ , HH.div_
[ HH.button [ HH.button
[ HP.style "padding: 0.5rem 1.25rem;" [ HP.style "padding: 0.5rem 1.25rem;"
, HP.type_ HP.ButtonSubmit , HP.type_ HP.ButtonSubmit
, maybe (HP.disabled true) (\_ -> HP.enabled true) wsConnection , maybe (HP.disabled true) (\_ -> HP.enabled true) wsInfo.connection
] ]
[ HH.text "Send Message to Server" ] [ HH.text "Send Message to Server" ]
] ]
@ -207,9 +209,9 @@ handleAction = case _ of
handleAction ConnectWebSocket handleAction ConnectWebSocket
Finalize -> do Finalize -> do
{ wsConnection } <- H.get { wsInfo } <- H.get
systemMessage "Finalize" systemMessage "Finalize"
case wsConnection of case wsInfo.connection of
Nothing -> systemMessage "No socket? How is that even possible?" Nothing -> systemMessage "No socket? How is that even possible?"
Just socket -> H.liftEffect $ WS.close socket Just socket -> H.liftEffect $ WS.close socket
@ -217,11 +219,11 @@ handleAction = case _ of
systemMessage $ renderError (UnknownError error) systemMessage $ renderError (UnknownError error)
ConnectWebSocket -> do ConnectWebSocket -> do
{ wsUrl } <- H.get { wsInfo } <- H.get
systemMessage ("Connecting to \"" <> wsUrl <> "\"...") systemMessage ("Connecting to \"" <> wsInfo.url <> "\"...")
webSocket <- H.liftEffect $ WS.create wsUrl [] webSocket <- H.liftEffect $ WS.create wsInfo.url []
H.liftEffect $ WS.setBinaryType webSocket ArrayBuffer H.liftEffect $ WS.setBinaryType webSocket ArrayBuffer
H.modify_ _ { wsConnection = Just webSocket } H.modify_ _ { wsInfo { connection = Just webSocket }}
void $ H.subscribe (HandleWebSocket <$> webSocketEmitter webSocket) void $ H.subscribe (HandleWebSocket <$> webSocketEmitter webSocket)
HandleAuthenticationInput authinp -> do HandleAuthenticationInput authinp -> do
@ -238,12 +240,12 @@ handleAction = case _ of
RegisterAttempt ev -> do RegisterAttempt ev -> do
H.liftEffect $ Event.preventDefault ev H.liftEffect $ Event.preventDefault ev
{ wsConnection, registrationForm } <- H.get { wsInfo, registrationForm } <- H.get
let login = registrationForm.login let login = registrationForm.login
email = registrationForm.email email = registrationForm.email
pass = registrationForm.pass pass = registrationForm.pass
case wsConnection, login, email, pass of case wsInfo.connection, login, email, pass of
Nothing, _, _, _ -> Nothing, _, _, _ ->
unableToSend "Not connected to server." unableToSend "Not connected to server."
@ -266,9 +268,9 @@ handleAction = case _ of
Closed -> do Closed -> do
unableToSend "Connection to server has been closed." unableToSend "Connection to server has been closed."
maybeCurrentConnection <- H.gets _.wsConnection maybeCurrentConnection <- H.gets _.wsInfo.connection
when (isJust maybeCurrentConnection) do when (isJust maybeCurrentConnection) do
H.modify_ _ { wsConnection = Nothing, canReconnect = true } H.modify_ _ { wsInfo { connection = Nothing, reconnect = true }}
Open -> do Open -> do
H.liftEffect $ do H.liftEffect $ do
@ -281,9 +283,9 @@ handleAction = case _ of
AuthenticationAttempt ev -> do AuthenticationAttempt ev -> do
H.liftEffect $ Event.preventDefault ev H.liftEffect $ Event.preventDefault ev
{ wsConnection, authenticationForm } <- H.get { wsInfo, authenticationForm } <- H.get
case wsConnection, authenticationForm.login, authenticationForm.pass of case wsInfo.connection, authenticationForm.login, authenticationForm.pass of
Nothing, _, _ -> Nothing, _, _ ->
unableToSend "Not connected to server." unableToSend "Not connected to server."
@ -303,9 +305,9 @@ handleAction = case _ of
Closed -> do Closed -> do
unableToSend "Connection to server has been closed." unableToSend "Connection to server has been closed."
maybeCurrentConnection <- H.gets _.wsConnection maybeCurrentConnection <- H.gets _.wsInfo.connection
when (isJust maybeCurrentConnection) do when (isJust maybeCurrentConnection) do
H.modify_ _ { wsConnection = Nothing, canReconnect = true } H.modify_ _ { wsInfo { connection = Nothing, reconnect = true }}
Open -> do Open -> do
H.liftEffect $ do H.liftEffect $ do
@ -342,14 +344,14 @@ handleAction = case _ of
appendMessage $ "[😈] Failed! Authentication server didn't send a valid message." appendMessage $ "[😈] Failed! Authentication server didn't send a valid message."
WebSocketOpen -> do WebSocketOpen -> do
{ wsUrl } <- H.get { wsInfo } <- H.get
systemMessage ("Successfully connected to WebSocket at \"" <> wsUrl <> "\"!🎉") systemMessage ("Successfully connected to WebSocket at \"" <> wsInfo.url <> "\"!🎉")
WebSocketClose { code, reason, wasClean } -> do WebSocketClose { code, reason, wasClean } -> do
systemMessage $ renderCloseMessage code wasClean reason systemMessage $ renderCloseMessage code wasClean reason
maybeCurrentConnection <- H.gets _.wsConnection maybeCurrentConnection <- H.gets _.wsInfo.connection
when (isJust maybeCurrentConnection) do when (isJust maybeCurrentConnection) do
H.modify_ _ { wsConnection = Nothing, canReconnect = true } H.modify_ _ { wsInfo { connection = Nothing, reconnect = true }}
WebSocketError errorType -> WebSocketError errorType ->
systemMessage $ renderError errorType systemMessage $ renderError errorType