From de88796773280de1f51911542d0c3f81d1bb358b Mon Sep 17 00:00:00 2001 From: Philippe Pittoli Date: Sun, 18 Jun 2023 01:10:36 +0200 Subject: [PATCH] DNSManager Interface: first draft (WIP). --- src/App/DNSManagerDomainsInterface.purs | 115 ++++++++++-------------- 1 file changed, 46 insertions(+), 69 deletions(-) diff --git a/src/App/DNSManagerDomainsInterface.purs b/src/App/DNSManagerDomainsInterface.purs index b16ba90..2cf716b 100644 --- a/src/App/DNSManagerDomainsInterface.purs +++ b/src/App/DNSManagerDomainsInterface.purs @@ -1,12 +1,15 @@ -module App.AuthenticationDaemonAdminInterface where +module App.DNSManagerDomainsInterface where -{- Administration interface for the authentication daemon. +{- Simple component with the list of own domains and a form to add a new domain. This interface should allow to: - - TODO: add, remove, search, validate users - - TODO: raise a user to admin + - TODO: display the list of own domains + - TODO: create new domains (with different TLDs) + + Some messages are lacking: + - TODO: get the list of TLDs (netlib.re, codelib.re, etc.) -} -import Prelude (Unit, Void, bind, discard, map, otherwise, pure, show, void, when, ($), (&&), (-), (<), (<$>), (<<<), (<>), (>=>), (>>=), not) +import Prelude import Bulma as Bulma @@ -40,9 +43,7 @@ import Web.Socket.WebSocket as WS import Effect.Class (class MonadEffect) import App.IPC as IPC -import App.Email as Email - -import App.Messages.AuthenticationDaemon as AuthD +import App.Messages.DNSManagerDaemon as DNSManager import Data.ArrayBuffer.Types (ArrayBuffer) import Web.Socket.BinaryType (BinaryType(ArrayBuffer)) @@ -140,7 +141,7 @@ type Query :: forall k. k -> Type type Query = Const Void type Input = String -data NewDomainForm +data NewDomainFormAction = INP_newdomain String data Action @@ -148,19 +149,20 @@ data Action | WebSocketParseError String | ConnectWebSocket - | HandleNewDomainInput NewDomainForm + | HandleNewDomainInput NewDomainFormAction - | AddUserAttempt Event + | NewDomainAttempt Event -- | Finalize | HandleWebSocket (WebSocketEvent WebSocketMessageType) -type StateAddUserForm = { login :: String, admin :: Boolean, email :: String, pass :: String } +-- TODO: TLD +type NewDomainForm = { new_domain :: String } type State = { messages :: Array String , messageHistoryLength :: Int - , newDomainForm :: StateAddUserForm + , newDomainForm :: NewDomainForm -- TODO: put network stuff in a record. , wsUrl :: String @@ -200,43 +202,30 @@ render { canReconnect, newDomainForm } = HH.div_ - [ Bulma.columns_ [ Bulma.column_ adduser_form ] + [ Bulma.columns_ [ Bulma.column_ newdomain_form, Bulma.column_ list_of_own_domains ] , render_messages - --, renderMaxHistoryLength messageHistoryLength , renderReconnectButton (isNothing wsConnection && canReconnect) ] where - adduser_form - = [ Bulma.h3 "Add a new user" + newdomain_form + = [ Bulma.h3 "Add a domain!" , render_adduser_form ] + list_of_own_domains + = [ Bulma.h3 "You domains: (TODO)" ] + should_be_disabled = (maybe (HP.disabled true) (\_ -> HP.enabled true) wsConnection) render_adduser_form = HH.form - [ HE.onSubmit AddUserAttempt ] + [ HE.onSubmit NewDomainAttempt ] [ Bulma.box_input "Your new domain" "awesomewebsite" -- title, placeholder (HandleNewDomainInput <<< INP_newdomain) -- action newDomainForm.new_domain -- value true -- validity (TODO) should_be_disabled -- condition - , Bulma.btn - (show newDomainForm.admin) -- value - (HandleNewDomainInput ADDUSER_toggle_admin) -- action1 - (HandleNewDomainInput ADDUSER_toggle_admin) -- action2 - true -- validity (TODO) - -- should_be_disabled -- condition - , Bulma.box_input "User email" "email" -- title, placeholder - (HandleNewDomainInput <<< ADDUSER_INP_email) -- action - newDomainForm.email -- value - true -- validity (TODO) - should_be_disabled -- condition - , Bulma.box_password "User password" "password" -- title, placeholder - (HandleNewDomainInput <<< ADDUSER_INP_pass) -- action - newDomainForm.pass -- value - true -- validity (TODO) - should_be_disabled -- condition + -- TODO: list of options for TLD , HH.div_ [ HH.button [ HP.style "padding: 0.5rem 1.25rem;" @@ -293,35 +282,23 @@ handleAction = case _ of void $ H.subscribe (HandleWebSocket <$> webSocketEmitter webSocket) HandleNewDomainInput adduserinp -> do - { newDomainForm } <- H.get case adduserinp of - ADDUSER_INP_login v -> H.modify_ _ { newDomainForm { login = v } } - ADDUSER_INP_email v -> H.modify_ _ { newDomainForm { email = v } } - ADDUSER_toggle_admin -> H.modify_ _ { newDomainForm { admin = not newDomainForm.admin } } - ADDUSER_INP_pass v -> H.modify_ _ { newDomainForm { pass = v } } + INP_newdomain v -> H.modify_ _ { newDomainForm { new_domain = v } } - AddUserAttempt ev -> do + NewDomainAttempt ev -> do H.liftEffect $ Event.preventDefault ev { wsConnection, newDomainForm } <- H.get - let login = newDomainForm.login - email = newDomainForm.email - pass = newDomainForm.pass + let new_domain = newDomainForm.new_domain - case wsConnection, login, email, pass of - Nothing, _, _, _ -> + case wsConnection, new_domain of + Nothing, _ -> unableToSend "Not connected to server." - Just _, "", _, _ -> - unableToSend "Write the user's login!" + Just _, "" -> + unableToSend "You didn't enter the new domain!" - Just _, _, "", _ -> - unableToSend "Write the user's email!" - - Just _, _, _, "" -> - unableToSend "Write the user's password!" - - Just webSocket, _, _, _ -> do + Just webSocket, _ -> do H.liftEffect (WS.readyState webSocket) >>= case _ of Connecting -> unableToSend "Still connecting to server." @@ -337,35 +314,35 @@ handleAction = case _ of Open -> do H.liftEffect $ do - ab <- AuthD.serialize $ AuthD.MkAddUser { login: login - , admin: newDomainForm.admin - , email: Just (Email.Email email) - , password: pass } + -- TODO: put chosen TLD + ab <- DNSManager.serialize $ DNSManager.MkNewDomain { domain: new_domain } sendArrayBuffer webSocket ab - appendMessageReset "[😇] Trying to add a user" + appendMessageReset "[😇] Trying to add a new domain" HandleWebSocket wsEvent -> case wsEvent of WebSocketMessage messageEvent -> do - receivedMessage <- H.liftEffect $ AuthD.deserialize messageEvent.message + receivedMessage <- H.liftEffect $ DNSManager.deserialize messageEvent.message case receivedMessage of -- Cases where we didn't understand the message. Left err -> do case err of - (AuthD.JSONERROR jerr) -> do + (DNSManager.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") + handleAction $ WebSocketParseError ("JSON parsing error: " <> jerr) + (DNSManager.UnknownError unerr) -> handleAction $ WebSocketParseError ("Parsing error: DNSManager.UnknownError" <> (show unerr)) + (DNSManager.UnknownNumber ) -> handleAction $ WebSocketParseError ("Parsing error: DNSManager.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 - (AuthD.GotUserAdded msg) -> do - appendMessage $ "[😈] Success! Server added user: " <> show msg.user + (DNSManager.MkError errmsg) -> do + appendMessage $ "[😈] Failed, reason is: " <> errmsg.reason + (DNSManager.MkDomainAlreadyExists _) -> do + appendMessage $ "[😈] Failed! The domain already exists." + (DNSManager.MkSuccess _) -> do + appendMessage $ "[😈] Success!" -- WTH?! _ -> do appendMessage $ "[😈] Failed! Authentication server didn't send a valid message." @@ -419,7 +396,7 @@ appendMessageGeneric clearField msg = do histSize <- H.gets _.messageHistoryLength if clearField then H.modify_ \st -> - st { messages = appendSingle histSize msg st.messages, newDomainForm { login = "" }} + st { messages = appendSingle histSize msg st.messages, newDomainForm { new_domain = "" }} else H.modify_ \st -> st { messages = appendSingle histSize msg st.messages } where