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

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
 

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 })