diff --git a/src/App/AuthenticationForm.purs b/src/App/AuthenticationForm.purs index 44f93cc..2d0e2fd 100644 --- a/src/App/AuthenticationForm.purs +++ b/src/App/AuthenticationForm.purs @@ -146,8 +146,15 @@ data Action | HandleEmailRegisterInputUpdate String | HandlePassRegisterInputUpdate String + -- (admin) AddUser. + | HandleSecretKeyAddUserInputUpdate String + | HandleLoginAddUserInputUpdate String + | HandleEmailAddUserInputUpdate String + | HandlePassAddUserInputUpdate String + | AuthenticationAttempt Event | RegisterAttempt Event + | AddUserAttempt Event | Finalize | HandleWebSocket (WebSocketEvent WebSocketMessageType) @@ -164,6 +171,12 @@ type State = , emailRegisterInputText :: String , passRegisterInputText :: String + -- Admin: AddUser. + , secretKeyAddUserInputText :: String + , loginAddUserInputText :: String + , emailAddUserInputText :: String + , passAddUserInputText :: String + -- Network stuff. , wsUrl :: String , wsConnection :: Maybe WS.WebSocket @@ -196,6 +209,12 @@ initialState input = , emailRegisterInputText: "" , passRegisterInputText: "" + -- Admin: AddUser. + , secretKeyAddUserInputText: "" + , loginAddUserInputText: "" + , emailAddUserInputText: "" + , passAddUserInputText: "" + -- Network stuff. , wsUrl: input , wsConnection: Nothing @@ -228,11 +247,18 @@ render { -- Register. loginRegisterInputText, emailRegisterInputText, - passRegisterInputText } + passRegisterInputText, + + -- AddUser. + secretKeyAddUserInputText, + loginAddUserInputText, + emailAddUserInputText, + passAddUserInputText } = HH.div [ HP.style wrapperStyle ] [ render_auth_form , render_register_form + , render_adduser_form , render_messages --, renderMaxHistoryLength messageHistoryLength , 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 renderFootnote :: String -> H.ComponentHTML Action () m @@ -377,6 +454,16 @@ handleAction = case _ of HandlePassRegisterInputUpdate text -> do 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 H.liftEffect $ Event.preventDefault ev @@ -421,6 +508,59 @@ handleAction = case _ of sendArrayBuffer webSocket ab 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 H.liftEffect $ Event.preventDefault ev diff --git a/src/App/UserPublic.purs b/src/App/UserPublic.purs index ef1426d..351f7ba 100644 --- a/src/App/UserPublic.purs +++ b/src/App/UserPublic.purs @@ -11,9 +11,11 @@ import Data.Newtype (class Newtype) -- | Lacks 'profile' and 'date_registration' attributes. -- type UserPublic row = { login :: String, uid :: Int | row } -- 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, -- | which can be exchanged in different messages. 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 })