AddUser (WIP: working but UserAdded answer isn't parsed properly).

master
Philippe Pittoli 2023-06-03 03:50:54 +02:00
parent 17b07ada18
commit 0bdef754ae
2 changed files with 145 additions and 3 deletions

View File

@ -146,8 +146,15 @@ data Action
| HandleEmailRegisterInputUpdate String | HandleEmailRegisterInputUpdate String
| HandlePassRegisterInputUpdate String | HandlePassRegisterInputUpdate String
-- (admin) AddUser.
| HandleSecretKeyAddUserInputUpdate String
| HandleLoginAddUserInputUpdate String
| HandleEmailAddUserInputUpdate String
| HandlePassAddUserInputUpdate String
| AuthenticationAttempt Event | AuthenticationAttempt Event
| RegisterAttempt Event | RegisterAttempt Event
| AddUserAttempt Event
| Finalize | Finalize
| HandleWebSocket (WebSocketEvent WebSocketMessageType) | HandleWebSocket (WebSocketEvent WebSocketMessageType)
@ -164,6 +171,12 @@ type State =
, emailRegisterInputText :: String , emailRegisterInputText :: String
, passRegisterInputText :: String , passRegisterInputText :: String
-- Admin: AddUser.
, secretKeyAddUserInputText :: String
, loginAddUserInputText :: String
, emailAddUserInputText :: String
, passAddUserInputText :: String
-- Network stuff. -- Network stuff.
, wsUrl :: String , wsUrl :: String
, wsConnection :: Maybe WS.WebSocket , wsConnection :: Maybe WS.WebSocket
@ -196,6 +209,12 @@ initialState input =
, emailRegisterInputText: "" , emailRegisterInputText: ""
, passRegisterInputText: "" , passRegisterInputText: ""
-- Admin: AddUser.
, secretKeyAddUserInputText: ""
, loginAddUserInputText: ""
, emailAddUserInputText: ""
, passAddUserInputText: ""
-- Network stuff. -- Network stuff.
, wsUrl: input , wsUrl: input
, wsConnection: Nothing , wsConnection: Nothing
@ -228,11 +247,18 @@ render {
-- Register. -- Register.
loginRegisterInputText, loginRegisterInputText,
emailRegisterInputText, emailRegisterInputText,
passRegisterInputText } passRegisterInputText,
-- AddUser.
secretKeyAddUserInputText,
loginAddUserInputText,
emailAddUserInputText,
passAddUserInputText }
= HH.div = HH.div
[ HP.style wrapperStyle ] [ HP.style wrapperStyle ]
[ render_auth_form [ render_auth_form
, render_register_form , render_register_form
, render_adduser_form
, render_messages , render_messages
--, renderMaxHistoryLength messageHistoryLength --, renderMaxHistoryLength messageHistoryLength
, renderReconnectButton (isNothing wsConnection && canReconnect) , renderReconnectButton (isNothing wsConnection && canReconnect)
@ -314,6 +340,57 @@ render {
] ]
] ]
render_adduser_form = HH.form
[ HE.onSubmit AddUserAttempt ]
[ HH.h2_ [ HH.text "(admin) Add User!" ]
, HH.p_
[ HH.div_
[ HH.input
[ inputCSS
, HP.type_ HP.InputText
, HP.value secretKeyAddUserInputText
, HE.onValueInput HandleSecretKeyAddUserInputUpdate
, maybe (HP.disabled true) (\_ -> HP.enabled true) wsConnection
]
]
, HH.div_
[ HH.input
[ inputCSS
, HP.type_ HP.InputText
, HP.value loginAddUserInputText
, HE.onValueInput HandleLoginAddUserInputUpdate
, maybe (HP.disabled true) (\_ -> HP.enabled true) wsConnection
]
]
, HH.div_
[ HH.input
[ inputCSS
, HP.type_ HP.InputText
, HP.value emailAddUserInputText
, HE.onValueInput HandleEmailAddUserInputUpdate
, maybe (HP.disabled true) (\_ -> HP.enabled true) wsConnection
]
]
, HH.div_
[ HH.input
[ inputCSS
, HP.type_ HP.InputPassword
, HP.value passAddUserInputText
, HE.onValueInput HandlePassAddUserInputUpdate
, 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" ]
]
]
]
render_messages = HH.ul_ $ map (\msg -> HH.li_ [ HH.text msg ]) messages render_messages = HH.ul_ $ map (\msg -> HH.li_ [ HH.text msg ]) messages
renderFootnote :: String -> H.ComponentHTML Action () m renderFootnote :: String -> H.ComponentHTML Action () m
@ -377,6 +454,16 @@ handleAction = case _ of
HandlePassRegisterInputUpdate text -> do HandlePassRegisterInputUpdate text -> do
H.modify_ _ { passRegisterInputText = text } H.modify_ _ { passRegisterInputText = text }
-- (admin) AddUser.
HandleSecretKeyAddUserInputUpdate text -> do
H.modify_ _ { secretKeyAddUserInputText = text }
HandleLoginAddUserInputUpdate text -> do
H.modify_ _ { loginAddUserInputText = text }
HandleEmailAddUserInputUpdate text -> do
H.modify_ _ { emailAddUserInputText = text }
HandlePassAddUserInputUpdate text -> do
H.modify_ _ { passAddUserInputText = text }
RegisterAttempt ev -> do RegisterAttempt ev -> do
H.liftEffect $ Event.preventDefault ev H.liftEffect $ Event.preventDefault ev
@ -421,6 +508,59 @@ handleAction = case _ of
sendArrayBuffer webSocket ab sendArrayBuffer webSocket ab
appendMessageReset "[😇] Trying to register" appendMessageReset "[😇] Trying to register"
AddUserAttempt ev -> do
H.liftEffect $ Event.preventDefault ev
{ wsConnection
, secretKeyAddUserInputText
, loginAddUserInputText
, emailAddUserInputText
, passAddUserInputText } <- H.get
case wsConnection
, secretKeyAddUserInputText
, loginAddUserInputText
, emailAddUserInputText
, passAddUserInputText of
Nothing, _, _, _, _ ->
unableToSend "Not connected to server."
Just _, "", _, _, _ ->
unableToSend "Write your secret key!"
Just _, _, "", _, _ ->
unableToSend "Write your login!"
Just _, _, _, "", _ ->
unableToSend "Write your email!"
Just _, _, _, _, "" ->
unableToSend "Write your password!"
Just webSocket, secret, login, email, pass -> 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
H.liftEffect $ do
ab <- AuthD.serialize $ AuthD.MkAddUser { shared_key: secret
, login: login
, email: Just (Email.Email email)
, password: pass
, phone: Nothing}
sendArrayBuffer webSocket ab
appendMessageReset "[😇] Trying to add a user"
AuthenticationAttempt ev -> do AuthenticationAttempt ev -> do
H.liftEffect $ Event.preventDefault ev H.liftEffect $ Event.preventDefault ev

View File

@ -11,9 +11,11 @@ import Data.Newtype (class Newtype)
-- | Lacks 'profile' and 'date_registration' attributes. -- | Lacks 'profile' and 'date_registration' attributes.
-- type UserPublic row = { login :: String, uid :: Int | row } -- type UserPublic row = { login :: String, uid :: Int | row }
-- TODO: add profile :: JSON any, date_registration :: Maybe Time -- TODO: add profile :: JSON any, date_registration :: Maybe Time
type UserPublic = { login :: String, uid :: Int } type UserPublic = { login :: String, uid :: Int, date_registration :: String }
-- | UserPublic.codec can be used to parse and encode public user info, -- | UserPublic.codec can be used to parse and encode public user info,
-- | which can be exchanged in different messages. -- | which can be exchanged in different messages.
codec :: JsonCodec UserPublic codec :: JsonCodec UserPublic
codec = CA.object "UserPublic" (CAR.record { "login": CA.string, "uid": CA.int }) codec = CA.object "UserPublic" (CAR.record { "login": CA.string
, "uid": CA.int
, "date_registration": CA.string })