DNSManager Interface: first draft (WIP).
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:
|
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
|
||||||
|
|
Loading…
Reference in New Issue