DNSManager Interface: first draft (WIP).
This commit is contained in:
parent
2352d2a3bb
commit
de88796773
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user