A single component for WS, another one for messages. WIP!

beta
Philippe Pittoli 2023-07-03 20:32:46 +02:00
parent 88aa805613
commit 51f5ba79f1
3 changed files with 161 additions and 252 deletions

View File

@ -1,6 +1,6 @@
module App.AuthenticationForm where module App.AuthenticationForm where
import Prelude (Unit, Void, bind, discard, map, show, void, when, ($), (&&), (<$>), (<<<), (<>), (>>=)) import Prelude (Unit, Void, bind, discard, map, show, void, when, ($), (&&), (<$>), (<<<), (<>), (>>=), pure, unit)
import Bulma as Bulma import Bulma as Bulma
@ -17,31 +17,26 @@ import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP import Halogen.HTML.Properties as HP
import Web.Event.Event (Event) import Web.Event.Event (Event)
import Web.Event.Event as Event import Web.Event.Event as Event
import Web.Socket.ReadyState (ReadyState(Connecting, Open, Closing, Closed))
import Web.Socket.WebSocket as WS
import Effect.Class (class MonadEffect) import Effect.Class (class MonadEffect)
import App.Utils
import App.IPC as IPC import App.IPC as IPC
import App.Email as Email import App.Email as Email
import App.Messages.AuthenticationDaemon as AuthD import App.Messages.AuthenticationDaemon as AuthD
import Data.ArrayBuffer.Types (ArrayBuffer) import Data.ArrayBuffer.Types (ArrayBuffer)
import Web.Socket.BinaryType (BinaryType(ArrayBuffer))
-------------------------------------------------------------------------------- data Output
-- Root component module = AuthToken (Tuple Int String)
-------------------------------------------------------------------------------- | MessageToSend ArrayBuffer
data Query a = MessageReceived ArrayBuffer a
data Output = AuthToken (Tuple Int String)
type Slot = H.Slot Query Output type Slot = H.Slot Query Output
type Query :: forall k. k -> Type -- No input.
type Query = Const Void type Input = Unit
type Input = String
data AuthenticationInput data AuthenticationInput
= AUTH_INP_login String = AUTH_INP_login String
@ -54,8 +49,8 @@ data RegisterInput
data Action data Action
= Initialize = Initialize
| WebSocketParseError String -- | WebSocketParseError String
| ConnectWebSocket -- | ConnectWebSocket
| HandleAuthenticationInput AuthenticationInput | HandleAuthenticationInput AuthenticationInput
| HandleRegisterInput RegisterInput | HandleRegisterInput RegisterInput
@ -63,25 +58,16 @@ data Action
| AuthenticationAttempt Event | AuthenticationAttempt Event
| RegisterAttempt Event | RegisterAttempt Event
| Finalize | Finalize
| HandleWebSocket (WebSocketEvent WebSocketMessageType) --| HandleWebSocket (WebSocketEvent WebSocketMessageType)
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 { authenticationForm :: StateAuthenticationForm
, messageHistoryLength :: Int
, authenticationForm :: StateAuthenticationForm
, registrationForm :: StateRegistrationForm , registrationForm :: StateRegistrationForm
, wsInfo :: WSInfo , wsUp :: Boolean
} }
component :: forall m. MonadAff m => H.Component Query Input Output m component :: forall m. MonadAff m => H.Component Query Input Output m
@ -92,35 +78,25 @@ component =
, eval: H.mkEval $ H.defaultEval , eval: H.mkEval $ H.defaultEval
{ initialize = Just Initialize { initialize = Just Initialize
, handleAction = handleAction , handleAction = handleAction
, handleQuery = handleQuery
, finalize = Just Finalize , finalize = Just Finalize
} }
} }
initialState :: Input -> State initialState :: Input -> State
initialState input = initialState _ =
{ messages: [] { authenticationForm: { login: "", pass: "" }
, messageHistoryLength: 10
, authenticationForm: { login: "", pass: "" }
, registrationForm: { login: "", email: "", pass: "" } , registrationForm: { login: "", email: "", pass: "" }
, wsInfo: { url: input , wsUp: true
, connection: Nothing
, reconnect: false
}
} }
render :: forall m. State -> H.ComponentHTML Action () m render :: forall m. State -> H.ComponentHTML Action () m
render { render { wsUp,
messages,
wsInfo,
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
, renderReconnectButton (isNothing wsInfo.connection && wsInfo.reconnect)
] ]
where where
@ -136,95 +112,58 @@ render {
render_auth_form = HH.form render_auth_form = HH.form
[ HE.onSubmit AuthenticationAttempt ] [ HE.onSubmit AuthenticationAttempt ]
[ Bulma.box_input "Login" "login" -- title, placeholder [ Bulma.box_input "Login" "login" -- title, placeholder
(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) wsInfo.connection) -- condition (if wsUp then (HP.enabled true) else (HP.disabled true)) -- 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) wsInfo.connection) -- condition (if wsUp then (HP.enabled true) else (HP.disabled true)) -- 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) wsInfo.connection , (if wsUp then (HP.enabled true) else (HP.disabled true))
] ]
[ HH.text "Send Message to Server" ] [ HH.text "Send Message to Server" ]
] ]
render_register_form = HH.form render_register_form = HH.form
[ HE.onSubmit RegisterAttempt ] [ HE.onSubmit RegisterAttempt ]
[ Bulma.box_input "Login" "login" -- title, placeholder [ Bulma.box_input "Login" "login" -- title, placeholder
(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) wsInfo.connection) -- condition (if wsUp then (HP.enabled true) else (HP.disabled true)) -- 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) wsInfo.connection) -- condition (if wsUp then (HP.enabled true) else (HP.disabled true)) -- 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) wsInfo.connection) -- condition (if wsUp then (HP.enabled true) else (HP.disabled true)) -- 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) wsInfo.connection , (if wsUp then (HP.enabled true) else (HP.disabled true))
] ]
[ HH.text "Send Message to Server" ] [ HH.text "Send Message to Server" ]
] ]
] ]
render_messages = HH.ul_ $ map (\msg -> HH.li_ [ HH.text msg ]) messages
renderFootnote :: String -> H.ComponentHTML Action () m
renderFootnote txt =
HH.div [ HP.style "margin-bottom: 0.125rem; color: grey;" ] [ HH.small_ [ HH.text txt ] ]
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"
]
handleAction :: forall m. MonadAff m => Action -> H.HalogenM State Action () Output m Unit handleAction :: forall m. MonadAff m => Action -> H.HalogenM State Action () Output m Unit
handleAction = case _ of handleAction = case _ of
Initialize -> Initialize -> pure unit
handleAction ConnectWebSocket -- systemMessage "Component initialized!"
Finalize -> do Finalize -> pure unit
{ wsInfo } <- H.get -- systemMessage "Finalize"
systemMessage "Finalize"
case wsInfo.connection of
Nothing -> systemMessage "No socket? How is that even possible?"
Just socket -> H.liftEffect $ WS.close socket
WebSocketParseError error ->
systemMessage $ renderError (UnknownError error)
ConnectWebSocket -> do
{ wsInfo } <- H.get
systemMessage ("Connecting to \"" <> wsInfo.url <> "\"...")
webSocket <- H.liftEffect $ WS.create wsInfo.url []
H.liftEffect $ WS.setBinaryType webSocket ArrayBuffer
H.modify_ _ { wsInfo { connection = Just webSocket }}
void $ H.subscribe (HandleWebSocket <$> webSocketEmitter webSocket)
HandleAuthenticationInput authinp -> do HandleAuthenticationInput authinp -> do
case authinp of case authinp of
@ -240,147 +179,81 @@ handleAction = case _ of
RegisterAttempt ev -> do RegisterAttempt ev -> do
H.liftEffect $ Event.preventDefault ev H.liftEffect $ Event.preventDefault ev
{ wsInfo, registrationForm } <- H.get { registrationForm } <- H.get
let login = registrationForm.login let login = registrationForm.login
email = registrationForm.email email = registrationForm.email
pass = registrationForm.pass pass = registrationForm.pass
case wsInfo.connection, login, email, pass of case login, email, pass of
Nothing, _, _, _ -> "", _, _ -> pure unit
unableToSend "Not connected to server." -- unableToSend "Write your login!"
Just _, "", _, _ -> _, "", _ -> pure unit
unableToSend "Write your login!" -- unableToSend "Write your email!"
Just _, _, "", _ -> _, _, "" -> pure unit
unableToSend "Write your email!" -- unableToSend "Write your password!"
Just _, _, _, "" -> _, _, _ -> do
unableToSend "Write your password!" message <- H.liftEffect $ AuthD.serialize $
AuthD.MkRegister { login: login
Just webSocket, _, _, _ -> do , email: Just (Email.Email email)
H.liftEffect (WS.readyState webSocket) >>= case _ of , password: pass }
Connecting -> H.raise $ MessageToSend message
unableToSend "Still connecting to server." -- appendMessage "[😇] Trying to register"
Closing ->
unableToSend "Connection to server is closing."
Closed -> do
unableToSend "Connection to server has been closed."
maybeCurrentConnection <- H.gets _.wsInfo.connection
when (isJust maybeCurrentConnection) do
H.modify_ _ { wsInfo { connection = Nothing, reconnect = true }}
Open -> do
H.liftEffect $ do
ab <- AuthD.serialize $ AuthD.MkRegister { login: login
, email: Just (Email.Email email)
, password: pass }
sendArrayBuffer webSocket ab
appendMessage "[😇] Trying to register"
AuthenticationAttempt ev -> do AuthenticationAttempt ev -> do
H.liftEffect $ Event.preventDefault ev H.liftEffect $ Event.preventDefault ev
{ wsInfo, authenticationForm } <- H.get { authenticationForm } <- H.get
case wsInfo.connection, authenticationForm.login, authenticationForm.pass of case authenticationForm.login, authenticationForm.pass of
Nothing, _, _ -> "" , _ -> pure unit
unableToSend "Not connected to server." -- unableToSend "Write your login!"
Just _ , "" , _ -> _ , "" -> pure unit
unableToSend "Write your login!" -- unableToSend "Write your password!"
Just _ , _ , "" -> login, pass -> do
unableToSend "Write your password!" message <- H.liftEffect $ AuthD.serialize $ AuthD.MkLogin { login: login, password: pass }
H.raise $ MessageToSend message
-- appendMessage $ "[😇] Trying to connect with login: " <> login
Just webSocket, login, pass -> do
H.liftEffect (WS.readyState webSocket) >>= case _ of
Connecting ->
unableToSend "Still connecting to server."
Closing -> handleQuery :: forall a m. MonadAff m => Query a -> H.HalogenM State Action () Output m (Maybe a)
unableToSend "Connection to server is closing." handleQuery = case _ of
MessageReceived message a -> do
receivedMessage <- H.liftEffect $ AuthD.deserialize message
case receivedMessage of
-- Cases where we didn't understand the message.
Left _ -> pure Nothing
--case err of
-- (AuthD.JSONERROR jerr) -> do
-- print_json_string messageEvent.message
-- handleAction $ WebSocketParseError ("JSON parsing error: " <> jerr <> " JSON is: " <> jerr)
-- (AuthD.UnknownError unerr) -> handleAction $ WebSocketParseError ("Parsing error: AuthD.UnknownError" <> (show unerr))
-- (AuthD.UnknownNumber ) -> handleAction $ WebSocketParseError ("Parsing error: AuthD.UnknownNumber")
Closed -> do -- Cases where we understood the message.
unableToSend "Connection to server has been closed." Right response -> do
maybeCurrentConnection <- H.gets _.wsInfo.connection case response of
when (isJust maybeCurrentConnection) do -- The authentication failed.
H.modify_ _ { wsInfo { connection = Nothing, reconnect = true }} (AuthD.GotError errmsg) -> pure (Just a)
-- appendMessage $ "[😈] Failed: " <> maybe "server didn't tell why" (\v -> v) errmsg.reason
Open -> do -- The authentication was a success!
H.liftEffect $ do (AuthD.GotToken msg) -> do
ab <- AuthD.serialize (AuthD.MkLogin { login: login, password: pass }) -- appendMessage $ "[😈] Success! user " <> (show msg.uid) <> " has token: " <> msg.token
sendArrayBuffer webSocket ab H.raise $ AuthToken (Tuple msg.uid msg.token)
appendMessage $ "[😇] Trying to connect with login: " <> login pure (Just a)
-- WTH?!
HandleWebSocket wsEvent -> _ -> pure Nothing
case wsEvent of -- appendMessage $ "[😈] Failed! Authentication server didn't send a valid message."
WebSocketMessage messageEvent -> do
receivedMessage <- H.liftEffect $ AuthD.deserialize messageEvent.message
case receivedMessage of
-- Cases where we didn't understand the message.
Left err -> do
case err of
(AuthD.JSONERROR jerr) -> do
print_json_string messageEvent.message
handleAction $ WebSocketParseError ("JSON parsing error: " <> jerr <> " JSON is: " <> jerr)
(AuthD.UnknownError unerr) -> handleAction $ WebSocketParseError ("Parsing error: AuthD.UnknownError" <> (show unerr))
(AuthD.UnknownNumber ) -> handleAction $ WebSocketParseError ("Parsing error: AuthD.UnknownNumber")
-- Cases where we understood the message.
Right response -> do
case response of
-- The authentication failed.
(AuthD.GotError errmsg) -> do
appendMessage $ "[😈] Failed: " <> maybe "server didn't tell why" (\v -> v) errmsg.reason
-- The authentication was a success!
(AuthD.GotToken msg) -> do
appendMessage $ "[😈] Success! user " <> (show msg.uid) <> " has token: " <> msg.token
H.raise $ AuthToken (Tuple msg.uid msg.token)
-- WTH?!
_ -> do
appendMessage $ "[😈] Failed! Authentication server didn't send a valid message."
WebSocketOpen -> do
{ wsInfo } <- H.get
systemMessage ("Successfully connected to WebSocket at \"" <> wsInfo.url <> "\"!🎉")
WebSocketClose { code, reason, wasClean } -> do
systemMessage $ renderCloseMessage code wasClean reason
maybeCurrentConnection <- H.gets _.wsInfo.connection
when (isJust maybeCurrentConnection) do
H.modify_ _ { wsInfo { connection = Nothing, reconnect = 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"
, "]"
]
print_json_string :: forall m. MonadEffect m => MonadState State m => ArrayBuffer -> m Unit print_json_string :: forall m. MonadEffect m => MonadState State m => ArrayBuffer -> m Unit
print_json_string arraybuffer = do print_json_string arraybuffer = do
-- fromTypedIPC :: ArrayBuffer -> Effect (Either ParseError (Tuple UInt String)) -- fromTypedIPC :: ArrayBuffer -> Effect (Either ParseError (Tuple UInt String))
value <- H.liftEffect $ IPC.fromTypedIPC arraybuffer value <- H.liftEffect $ IPC.fromTypedIPC arraybuffer
appendMessage $ case (value) of pure unit
Left _ -> "Cannot even fromTypedIPC the message." --appendMessage $ case (value) of
Right (Tuple messageTypeNumber string) -> "Number is: " <> show messageTypeNumber <> ", received string: " <> string -- Left _ -> "Cannot even fromTypedIPC the message."
-- Right (Tuple messageTypeNumber string) -> "Number is: " <> show messageTypeNumber <> ", received string: " <> string

View File

@ -7,6 +7,7 @@ import Bulma as Bulma
import Data.Maybe (Maybe(..)) import Data.Maybe (Maybe(..))
import Data.Tuple (Tuple(..)) import Data.Tuple (Tuple(..))
import App.AuthenticationForm as AF import App.AuthenticationForm as AF
import App.WS as WS
import App.AuthenticationDaemonAdminInterface as AAI import App.AuthenticationDaemonAdminInterface as AAI
import App.DNSManagerDomainsInterface as NewDomainInterface import App.DNSManagerDomainsInterface as NewDomainInterface
import Halogen as H import Halogen as H
@ -15,19 +16,29 @@ import Type.Proxy (Proxy(..))
import Effect.Aff.Class (class MonadAff) import Effect.Aff.Class (class MonadAff)
data Action data Action
= Authenticated AF.Output -- User has been authenticated. = OutputAuthComponent AF.Output -- User has been authenticated.
| AuthDEvent WS.Output -- Events from authd.
| DNSManagerDEvent WS.Output -- Events from dnsmanagerd.
type State = { token :: Maybe String, uid :: Maybe Int } type State = { token :: Maybe String
, uid :: Maybe Int
, auth_ws_connected :: Boolean
, dns_ws_connected :: Boolean
}
type ChildSlots = type ChildSlots =
( af :: AF.Slot Unit ( af :: AF.Slot Unit
, ws_auth :: WS.Slot Unit
, ws_dns :: WS.Slot Unit
, aai :: AAI.Slot Unit , aai :: AAI.Slot Unit
, ndi :: NewDomainInterface.Slot Unit , ndi :: NewDomainInterface.Slot Unit
) )
_af = Proxy :: Proxy "af" _af = Proxy :: Proxy "af"
_aai = Proxy :: Proxy "aai" _ws_auth = Proxy :: Proxy "ws_auth"
_ndi = Proxy :: Proxy "ndi" _ws_dns = Proxy :: Proxy "ws_dns"
_aai = Proxy :: Proxy "aai"
_ndi = Proxy :: Proxy "ndi"
component :: forall q i o m. MonadAff m => H.Component q i o m component :: forall q i o m. MonadAff m => H.Component q i o m
component = component =
@ -38,12 +49,18 @@ component =
} }
initialState :: forall i. i -> State initialState :: forall i. i -> State
initialState _ = { token: Nothing, uid: Nothing } initialState _ = { token: Nothing
, uid: Nothing
, auth_ws_connected: false
, dns_ws_connected: false
}
render :: forall m. MonadAff m => State -> H.ComponentHTML Action ChildSlots m render :: forall m. MonadAff m => State -> H.ComponentHTML Action ChildSlots m
render state render state
= HH.div_ $ = HH.div_ $
[ render_auth_form [ render_auth_WS
, render_dnsmanager_WS
, render_auth_form
, render_authd_admin_interface , render_authd_admin_interface
, render_newdomain_interface , render_newdomain_interface
, div_token , div_token
@ -52,9 +69,17 @@ render state
div_token :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad div_token :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad
div_token = Bulma.box [ Bulma.p ("User [" <> show state.uid <> "] has token: " <> show state.token) ] div_token = Bulma.box [ Bulma.p ("User [" <> show state.uid <> "] has token: " <> show state.token) ]
render_auth_WS :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad
render_auth_WS = Bulma.box [ HH.slot _ws_auth unit WS.component "ws://127.0.0.1:8080" AuthDEvent ]
render_dnsmanager_WS :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad
render_dnsmanager_WS = Bulma.box $ case state.token of
Nothing -> [ Bulma.p "We don't have a token right now." ]
Just _ -> [ HH.slot _ws_dns unit WS.component "ws://127.0.0.1:8081" DNSManagerDEvent ]
render_auth_form :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad render_auth_form :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad
render_auth_form = Bulma.box $ case state.token of render_auth_form = Bulma.box $ case state.token of
Nothing -> [ HH.slot _af unit AF.component "ws://127.0.0.1:8080" Authenticated ] Nothing -> [ HH.slot _af unit AF.component unit OutputAuthComponent ]
Just current_token -> [ Bulma.p ("Token is: " <> current_token) ] Just current_token -> [ Bulma.p ("Token is: " <> current_token) ]
render_authd_admin_interface :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad render_authd_admin_interface :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad
@ -75,4 +100,19 @@ render state
handleAction :: forall o monad. MonadAff monad => Action -> H.HalogenM State Action ChildSlots o monad Unit handleAction :: forall o monad. MonadAff monad => Action -> H.HalogenM State Action ChildSlots o monad Unit
handleAction = case _ of handleAction = case _ of
Authenticated (AF.AuthToken (Tuple uid token)) -> H.modify_ _ { uid = Just uid, token = Just token } OutputAuthComponent ev -> case ev of
AF.AuthToken (Tuple uid token) -> H.modify_ _ { uid = Just uid, token = Just token }
AF.MessageToSend message -> do
H.tell _ws_auth unit (WS.ToSend message)
AuthDEvent ev -> case ev of
WS.MessageReceived (Tuple _ message) ->
H.tell _af unit (AF.MessageReceived message)
WS.WSJustConnected -> H.modify_ _ { auth_ws_connected = true }
WS.WSJustClosed -> H.modify_ _ { auth_ws_connected = false }
DNSManagerDEvent ev -> case ev of
WS.MessageReceived (Tuple _ _) -> pure unit -- TODO
WS.WSJustConnected -> H.modify_ _ { dns_ws_connected = true }
WS.WSJustClosed -> H.modify_ _ { dns_ws_connected = false }

View File

@ -22,8 +22,9 @@ import App.Utils
import Data.ArrayBuffer.Types (ArrayBuffer) import Data.ArrayBuffer.Types (ArrayBuffer)
import Web.Socket.BinaryType (BinaryType(ArrayBuffer)) import Web.Socket.BinaryType (BinaryType(ArrayBuffer))
-- Input = url -- Input is the WS url.
type Input = String type Input = String
-- MessageReceived (Tuple URL message) -- MessageReceived (Tuple URL message)
data Output data Output
= MessageReceived (Tuple String ArrayBuffer) -- Provide a received message to the parent. = MessageReceived (Tuple String ArrayBuffer) -- Provide a received message to the parent.
@ -31,14 +32,11 @@ data Output
| WSJustClosed -- Inform the parent the connection is down. | WSJustClosed -- Inform the parent the connection is down.
--| AppendSystemMessage String -- System message to print. --| AppendSystemMessage String -- System message to print.
--| AppendMessage String -- Basic message to print. --| AppendMessage String -- Basic message to print.
--type Slot = H.Slot Query Output
--type Query :: forall k. k -> Type type Slot = H.Slot Query Output
data Query a = ToSend ArrayBuffer a
data NewDomainFormAction data Query a
= INP_newdomain String = ToSend ArrayBuffer a
| UpdateSelectedDomain String
data Action data Action
= Initialize = Initialize
@ -70,6 +68,7 @@ component =
, eval: H.mkEval $ H.defaultEval , eval: H.mkEval $ H.defaultEval
{ initialize = Just Initialize { initialize = Just Initialize
, handleAction = handleAction , handleAction = handleAction
, handleQuery = handleQuery
, finalize = Just Finalize , finalize = Just Finalize
} }
} }
@ -147,7 +146,7 @@ handleAction action = do
HandleWebSocket wsEvent -> do HandleWebSocket wsEvent -> do
case wsEvent of case wsEvent of
WebSocketMessage received_message -> do WebSocketMessage received_message -> do
appendMessage $ "[😈] Received a message, ignored for now" appendMessage $ "[😈] Received a message"
H.raise $ MessageReceived $ Tuple wsInfo.url received_message.message H.raise $ MessageReceived $ Tuple wsInfo.url received_message.message
WebSocketOpen -> do WebSocketOpen -> do
@ -216,6 +215,3 @@ handleQuery = case _ of
H.liftEffect $ do H.liftEffect $ do
sendArrayBuffer webSocket message sendArrayBuffer webSocket message
pure (Just a) pure (Just a)
-- Request reply ->
-- pure (Just (reply true))