A single component for WS, another one for messages. WIP!
This commit is contained in:
parent
88aa805613
commit
51f5ba79f1
@ -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
|
||||||
|
@ -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 }
|
||||||
|
|
||||||
|
@ -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))
|
|
||||||
|
Loading…
Reference in New Issue
Block a user