DNSManager Interface: first draft (WIP).

beta
Philippe Pittoli 2023-06-18 01:10:36 +02:00
parent 2352d2a3bb
commit de88796773
1 changed files with 46 additions and 69 deletions

View File

@ -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: This interface should allow to:
- TODO: add, remove, search, validate users - TODO: display the list of own domains
- TODO: raise a user to admin - 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 import Bulma as Bulma
@ -40,9 +43,7 @@ import Web.Socket.WebSocket as WS
import Effect.Class (class MonadEffect) import Effect.Class (class MonadEffect)
import App.IPC as IPC import App.IPC as IPC
import App.Email as Email import App.Messages.DNSManagerDaemon as DNSManager
import App.Messages.AuthenticationDaemon as AuthD
import Data.ArrayBuffer.Types (ArrayBuffer) import Data.ArrayBuffer.Types (ArrayBuffer)
import Web.Socket.BinaryType (BinaryType(ArrayBuffer)) import Web.Socket.BinaryType (BinaryType(ArrayBuffer))
@ -140,7 +141,7 @@ type Query :: forall k. k -> Type
type Query = Const Void type Query = Const Void
type Input = String type Input = String
data NewDomainForm data NewDomainFormAction
= INP_newdomain String = INP_newdomain String
data Action data Action
@ -148,19 +149,20 @@ data Action
| WebSocketParseError String | WebSocketParseError String
| ConnectWebSocket | ConnectWebSocket
| HandleNewDomainInput NewDomainForm | HandleNewDomainInput NewDomainFormAction
| AddUserAttempt Event | NewDomainAttempt Event
-- | Finalize -- | Finalize
| HandleWebSocket (WebSocketEvent WebSocketMessageType) | HandleWebSocket (WebSocketEvent WebSocketMessageType)
type StateAddUserForm = { login :: String, admin :: Boolean, email :: String, pass :: String } -- TODO: TLD
type NewDomainForm = { new_domain :: String }
type State = type State =
{ messages :: Array String { messages :: Array String
, messageHistoryLength :: Int , messageHistoryLength :: Int
, newDomainForm :: StateAddUserForm , newDomainForm :: NewDomainForm
-- TODO: put network stuff in a record. -- TODO: put network stuff in a record.
, wsUrl :: String , wsUrl :: String
@ -200,43 +202,30 @@ render {
canReconnect, canReconnect,
newDomainForm } newDomainForm }
= HH.div_ = HH.div_
[ Bulma.columns_ [ Bulma.column_ adduser_form ] [ Bulma.columns_ [ Bulma.column_ newdomain_form, Bulma.column_ list_of_own_domains ]
, render_messages , render_messages
--, renderMaxHistoryLength messageHistoryLength
, renderReconnectButton (isNothing wsConnection && canReconnect) , renderReconnectButton (isNothing wsConnection && canReconnect)
] ]
where where
adduser_form newdomain_form
= [ Bulma.h3 "Add a new user" = [ Bulma.h3 "Add a domain!"
, render_adduser_form , render_adduser_form
] ]
list_of_own_domains
= [ Bulma.h3 "You domains: (TODO)" ]
should_be_disabled = (maybe (HP.disabled true) (\_ -> HP.enabled true) wsConnection) should_be_disabled = (maybe (HP.disabled true) (\_ -> HP.enabled true) wsConnection)
render_adduser_form = HH.form render_adduser_form = HH.form
[ HE.onSubmit AddUserAttempt ] [ HE.onSubmit NewDomainAttempt ]
[ Bulma.box_input "Your new domain" "awesomewebsite" -- title, placeholder [ Bulma.box_input "Your new domain" "awesomewebsite" -- title, placeholder
(HandleNewDomainInput <<< INP_newdomain) -- action (HandleNewDomainInput <<< INP_newdomain) -- action
newDomainForm.new_domain -- value newDomainForm.new_domain -- value
true -- validity (TODO) true -- validity (TODO)
should_be_disabled -- condition should_be_disabled -- condition
, Bulma.btn -- TODO: list of options for TLD
(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
, HH.div_ , HH.div_
[ HH.button [ HH.button
[ HP.style "padding: 0.5rem 1.25rem;" [ HP.style "padding: 0.5rem 1.25rem;"
@ -293,35 +282,23 @@ handleAction = case _ of
void $ H.subscribe (HandleWebSocket <$> webSocketEmitter webSocket) void $ H.subscribe (HandleWebSocket <$> webSocketEmitter webSocket)
HandleNewDomainInput adduserinp -> do HandleNewDomainInput adduserinp -> do
{ newDomainForm } <- H.get
case adduserinp of case adduserinp of
ADDUSER_INP_login v -> H.modify_ _ { newDomainForm { login = v } } INP_newdomain v -> H.modify_ _ { newDomainForm { new_domain = 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 } }
AddUserAttempt ev -> do NewDomainAttempt ev -> do
H.liftEffect $ Event.preventDefault ev H.liftEffect $ Event.preventDefault ev
{ wsConnection, newDomainForm } <- H.get { wsConnection, newDomainForm } <- H.get
let login = newDomainForm.login let new_domain = newDomainForm.new_domain
email = newDomainForm.email
pass = newDomainForm.pass
case wsConnection, login, email, pass of case wsConnection, new_domain of
Nothing, _, _, _ -> Nothing, _ ->
unableToSend "Not connected to server." unableToSend "Not connected to server."
Just _, "", _, _ -> Just _, "" ->
unableToSend "Write the user's login!" unableToSend "You didn't enter the new domain!"
Just _, _, "", _ -> Just webSocket, _ -> do
unableToSend "Write the user's email!"
Just _, _, _, "" ->
unableToSend "Write the user's password!"
Just webSocket, _, _, _ -> do
H.liftEffect (WS.readyState webSocket) >>= case _ of H.liftEffect (WS.readyState webSocket) >>= case _ of
Connecting -> Connecting ->
unableToSend "Still connecting to server." unableToSend "Still connecting to server."
@ -337,35 +314,35 @@ handleAction = case _ of
Open -> do Open -> do
H.liftEffect $ do H.liftEffect $ do
ab <- AuthD.serialize $ AuthD.MkAddUser { login: login -- TODO: put chosen TLD
, admin: newDomainForm.admin ab <- DNSManager.serialize $ DNSManager.MkNewDomain { domain: new_domain }
, email: Just (Email.Email email)
, password: pass }
sendArrayBuffer webSocket ab sendArrayBuffer webSocket ab
appendMessageReset "[😇] Trying to add a user" appendMessageReset "[😇] Trying to add a new domain"
HandleWebSocket wsEvent -> HandleWebSocket wsEvent ->
case wsEvent of case wsEvent of
WebSocketMessage messageEvent -> do WebSocketMessage messageEvent -> do
receivedMessage <- H.liftEffect $ AuthD.deserialize messageEvent.message receivedMessage <- H.liftEffect $ DNSManager.deserialize messageEvent.message
case receivedMessage of case receivedMessage of
-- Cases where we didn't understand the message. -- Cases where we didn't understand the message.
Left err -> do Left err -> do
case err of case err of
(AuthD.JSONERROR jerr) -> do (DNSManager.JSONERROR jerr) -> do
print_json_string messageEvent.message print_json_string messageEvent.message
handleAction $ WebSocketParseError ("JSON parsing error: " <> jerr <> " JSON is: " <> jerr) handleAction $ WebSocketParseError ("JSON parsing error: " <> jerr)
(AuthD.UnknownError unerr) -> handleAction $ WebSocketParseError ("Parsing error: AuthD.UnknownError" <> (show unerr)) (DNSManager.UnknownError unerr) -> handleAction $ WebSocketParseError ("Parsing error: DNSManager.UnknownError" <> (show unerr))
(AuthD.UnknownNumber ) -> handleAction $ WebSocketParseError ("Parsing error: AuthD.UnknownNumber") (DNSManager.UnknownNumber ) -> handleAction $ WebSocketParseError ("Parsing error: DNSManager.UnknownNumber")
-- Cases where we understood the message. -- Cases where we understood the message.
Right response -> do Right response -> do
case response of case response of
-- The authentication failed. -- The authentication failed.
(AuthD.GotError errmsg) -> do (DNSManager.MkError errmsg) -> do
appendMessage $ "[😈] Failed: " <> maybe "server didn't tell why" (\v -> v) errmsg.reason appendMessage $ "[😈] Failed, reason is: " <> errmsg.reason
(AuthD.GotUserAdded msg) -> do (DNSManager.MkDomainAlreadyExists _) -> do
appendMessage $ "[😈] Success! Server added user: " <> show msg.user appendMessage $ "[😈] Failed! The domain already exists."
(DNSManager.MkSuccess _) -> do
appendMessage $ "[😈] Success!"
-- WTH?! -- WTH?!
_ -> do _ -> do
appendMessage $ "[😈] Failed! Authentication server didn't send a valid message." appendMessage $ "[😈] Failed! Authentication server didn't send a valid message."
@ -419,7 +396,7 @@ appendMessageGeneric clearField msg = do
histSize <- H.gets _.messageHistoryLength histSize <- H.gets _.messageHistoryLength
if clearField if clearField
then H.modify_ \st -> 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 -> else H.modify_ \st ->
st { messages = appendSingle histSize msg st.messages } st { messages = appendSingle histSize msg st.messages }
where where