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

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

Browse Source
This commit is contained in:
Philippe Pittoli 2023-07-03 20:32:46 +02:00
parent 88aa805613
commit 51f5ba79f1
3 changed files with 161 additions and 252 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

337
src/App/AuthenticationForm.purs
View File

@ -1,6 +1,6 @@
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
@ -17,31 +17,26 @@ import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import Web.Event.Event (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 App.Utils
import App.IPC as IPC
import App.Email as Email
import App.Messages.AuthenticationDaemon as AuthD
import Data.ArrayBuffer.Types (ArrayBuffer)
import Web.Socket.BinaryType (BinaryType(ArrayBuffer))
--------------------------------------------------------------------------------
-- Root component module
--------------------------------------------------------------------------------
data Output
= 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 Query :: forall k. k -> Type
type Query = Const Void
type Input = String
-- No input.
type Input = Unit
data AuthenticationInput
= AUTH_INP_login String
@ -54,8 +49,8 @@ data RegisterInput
data Action
= Initialize
| WebSocketParseError String
| ConnectWebSocket
-- | WebSocketParseError String
-- | ConnectWebSocket
| HandleAuthenticationInput AuthenticationInput
| HandleRegisterInput RegisterInput
@ -63,25 +58,16 @@ data Action
| AuthenticationAttempt Event
| RegisterAttempt Event
| Finalize
| HandleWebSocket (WebSocketEvent WebSocketMessageType)
--| HandleWebSocket (WebSocketEvent WebSocketMessageType)
type StateAuthenticationForm = { login :: String, pass :: String }
type StateRegistrationForm = { login :: String, email :: String, pass :: String }
type WSInfo
= { url :: String
, connection :: Maybe WS.WebSocket
, reconnect :: Boolean
}
type State =
{ messages :: Array String
, messageHistoryLength :: Int
, authenticationForm :: StateAuthenticationForm
{ authenticationForm :: StateAuthenticationForm
, registrationForm :: StateRegistrationForm
, wsInfo :: WSInfo
, wsUp :: Boolean
}
component :: forall m. MonadAff m => H.Component Query Input Output m
@ -92,35 +78,25 @@ component =
, eval: H.mkEval $ H.defaultEval
{ initialize = Just Initialize
, handleAction = handleAction
, handleQuery = handleQuery
, finalize = Just Finalize
}
}
initialState :: Input -> State
initialState input =
{ messages: []
, messageHistoryLength: 10
, authenticationForm: { login: "", pass: "" }
initialState _ =
{ authenticationForm: { login: "", pass: "" }
, registrationForm: { login: "", email: "", pass: "" }
, wsInfo: { url: input
, connection: Nothing
, reconnect: false
}
, wsUp: true
}
render :: forall m. State -> H.ComponentHTML Action () m
render {
messages,
wsInfo,
render { wsUp,
authenticationForm,
registrationForm }
= HH.div_
[ Bulma.columns_ [ Bulma.column_ auth_form, Bulma.column_ register_form ]
, render_messages
, renderReconnectButton (isNothing wsInfo.connection && wsInfo.reconnect)
]
where
@ -136,95 +112,58 @@ render {
render_auth_form = HH.form
[ HE.onSubmit AuthenticationAttempt ]
[ Bulma.box_input "Login" "login" -- title, placeholder
(HandleAuthenticationInput <<< AUTH_INP_login) -- action
authenticationForm.login -- value
true -- validity (TODO)
(maybe (HP.disabled true) (\_ -> HP.enabled true) wsInfo.connection) -- condition
, Bulma.box_password "Password" "password" -- title, placeholder
(HandleAuthenticationInput <<< AUTH_INP_pass) -- action
authenticationForm.pass -- value
true -- validity (TODO)
(maybe (HP.disabled true) (\_ -> HP.enabled true) wsInfo.connection) -- condition
[ Bulma.box_input "Login" "login" -- title, placeholder
(HandleAuthenticationInput <<< AUTH_INP_login) -- action
authenticationForm.login -- value
true -- validity (TODO)
(if wsUp then (HP.enabled true) else (HP.disabled true)) -- condition
, Bulma.box_password "Password" "password" -- title, placeholder
(HandleAuthenticationInput <<< AUTH_INP_pass) -- action
authenticationForm.pass -- value
true -- validity (TODO)
(if wsUp then (HP.enabled true) else (HP.disabled true)) -- condition
, HH.button
[ HP.style "padding: 0.5rem 1.25rem;"
, 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" ]
]
render_register_form = HH.form
[ HE.onSubmit RegisterAttempt ]
[ Bulma.box_input "Login" "login" -- title, placeholder
(HandleRegisterInput <<< REG_INP_login) -- action
registrationForm.login -- value
true -- validity (TODO)
(maybe (HP.disabled true) (\_ -> HP.enabled true) wsInfo.connection) -- condition
, Bulma.box_input "Email" "email@example.com" -- title, placeholder
(HandleRegisterInput <<< REG_INP_email) -- action
registrationForm.email -- value
true -- validity (TODO)
(maybe (HP.disabled true) (\_ -> HP.enabled true) wsInfo.connection) -- condition
, Bulma.box_password "Password" "password" -- title, placeholder
(HandleRegisterInput <<< REG_INP_pass) -- action
registrationForm.pass -- value
true -- validity (TODO)
(maybe (HP.disabled true) (\_ -> HP.enabled true) wsInfo.connection) -- condition
[ Bulma.box_input "Login" "login" -- title, placeholder
(HandleRegisterInput <<< REG_INP_login) -- action
registrationForm.login -- value
true -- validity (TODO)
(if wsUp then (HP.enabled true) else (HP.disabled true)) -- condition
, Bulma.box_input "Email" "email@example.com" -- title, placeholder
(HandleRegisterInput <<< REG_INP_email) -- action
registrationForm.email -- value
true -- validity (TODO)
(if wsUp then (HP.enabled true) else (HP.disabled true)) -- condition
, Bulma.box_password "Password" "password" -- title, placeholder
(HandleRegisterInput <<< REG_INP_pass) -- action
registrationForm.pass -- value
true -- validity (TODO)
(if wsUp then (HP.enabled true) else (HP.disabled true)) -- condition
, HH.div_
[ HH.button
[ HP.style "padding: 0.5rem 1.25rem;"
, 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" ]
]
]
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 = case _ of
Initialize ->
handleAction ConnectWebSocket
Initialize -> pure unit
-- systemMessage "Component initialized!"
Finalize -> do
{ wsInfo } <- H.get
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)
Finalize -> pure unit
-- systemMessage "Finalize"
HandleAuthenticationInput authinp -> do
case authinp of
@ -240,147 +179,81 @@ handleAction = case _ of
RegisterAttempt ev -> do
H.liftEffect $ Event.preventDefault ev
{ wsInfo, registrationForm } <- H.get
{ registrationForm } <- H.get
let login = registrationForm.login
email = registrationForm.email
pass = registrationForm.pass
case wsInfo.connection, login, email, pass of
Nothing, _, _, _ ->
unableToSend "Not connected to server."
case login, email, pass of
"", _, _ -> pure unit
-- unableToSend "Write your login!"
Just _, "", _, _ ->
unableToSend "Write your login!"
_, "", _ -> pure unit
-- unableToSend "Write your email!"
Just _, _, "", _ ->
unableToSend "Write your email!"
_, _, "" -> pure unit
-- unableToSend "Write your password!"
Just _, _, _, "" ->
unableToSend "Write your password!"
Just webSocket, _, _, _ -> 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 _.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"
_, _, _ -> do
message <- H.liftEffect $ AuthD.serialize $
AuthD.MkRegister { login: login
, email: Just (Email.Email email)
, password: pass }
H.raise $ MessageToSend message
-- appendMessage "[😇] Trying to register"
AuthenticationAttempt ev -> do
H.liftEffect $ Event.preventDefault ev
{ wsInfo, authenticationForm } <- H.get
{ authenticationForm } <- H.get
case wsInfo.connection, authenticationForm.login, authenticationForm.pass of
Nothing, _, _ ->
unableToSend "Not connected to server."
case authenticationForm.login, authenticationForm.pass of
"" , _ -> pure unit
-- unableToSend "Write your login!"
Just _ , "" , _ ->
unableToSend "Write your login!"
_ , "" -> pure unit
-- unableToSend "Write your password!"
Just _ , _ , "" ->
unableToSend "Write your password!"
login, pass -> do
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 ->
unableToSend "Connection to server is closing."
handleQuery :: forall a m. MonadAff m => Query a -> H.HalogenM State Action () Output m (Maybe a)
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
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.MkLogin { login: login, password: pass })
sendArrayBuffer webSocket ab
appendMessage $ "[😇] Trying to connect with login: " <> login
HandleWebSocket wsEvent ->
case wsEvent of
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"
, "]"
]
-- Cases where we understood the message.
Right response -> do
case response of
-- The authentication failed.
(AuthD.GotError errmsg) -> pure (Just a)
-- 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)
pure (Just a)
-- WTH?!
_ -> pure Nothing
-- appendMessage $ "[😈] Failed! Authentication server didn't send a valid message."
print_json_string :: forall m. MonadEffect m => MonadState State m => ArrayBuffer -> m Unit
print_json_string arraybuffer = do
-- fromTypedIPC :: ArrayBuffer -> Effect (Either ParseError (Tuple UInt String))
value <- H.liftEffect $ IPC.fromTypedIPC arraybuffer
appendMessage $ case (value) of
Left _ -> "Cannot even fromTypedIPC the message."
Right (Tuple messageTypeNumber string) -> "Number is: " <> show messageTypeNumber <> ", received string: " <> string
pure unit
--appendMessage $ case (value) of
-- Left _ -> "Cannot even fromTypedIPC the message."
-- Right (Tuple messageTypeNumber string) -> "Number is: " <> show messageTypeNumber <> ", received string: " <> string

58
src/App/Container.purs
View File

@ -7,6 +7,7 @@ import Bulma as Bulma
import Data.Maybe (Maybe(..))
import Data.Tuple (Tuple(..))
import App.AuthenticationForm as AF
import App.WS as WS
import App.AuthenticationDaemonAdminInterface as AAI
import App.DNSManagerDomainsInterface as NewDomainInterface
import Halogen as H
@ -15,19 +16,29 @@ import Type.Proxy (Proxy(..))
import Effect.Aff.Class (class MonadAff)
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 =
( af :: AF.Slot Unit
, ws_auth :: WS.Slot Unit
, ws_dns :: WS.Slot Unit
, aai :: AAI.Slot Unit
, ndi :: NewDomainInterface.Slot Unit
)
_af = Proxy :: Proxy "af"
_aai = Proxy :: Proxy "aai"
_ndi = Proxy :: Proxy "ndi"
_af = Proxy :: Proxy "af"
_ws_auth = Proxy :: Proxy "ws_auth"
_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 =
@ -38,12 +49,18 @@ component =
}
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 state
= HH.div_ $
[ render_auth_form
[ render_auth_WS
, render_dnsmanager_WS
, render_auth_form
, render_authd_admin_interface
, render_newdomain_interface
, div_token
@ -52,9 +69,17 @@ render state
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) ]
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 = 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) ]
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 = 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 }

18
src/App/WS.purs
View File

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