Refactoring of Container: split code into multiple functions (WIP).
This commit is contained in:
parent
833f1024ef
commit
999d801eaf
1 changed files with 428 additions and 441 deletions
|
|
@ -43,7 +43,7 @@
|
|||
-- | - mail recovery
|
||||
module App.Container where
|
||||
|
||||
import Prelude (Unit, bind, discard, unit, ($), (=<<), (<>), show, pure, (+), (&&), (>))
|
||||
import Prelude (Unit, bind, discard, unit, ($), (=<<), (<>), show, pure, (+), (&&), (>), (<<<))
|
||||
|
||||
import Web as Web
|
||||
|
||||
|
|
@ -113,10 +113,8 @@ max_keepalive = 60 :: Int
|
|||
wsURLauthd = "wss://www.netlib.re/ws/authd" :: String
|
||||
wsURLdnsmanagerd = "wss://www.netlib.re/ws/dnsmanagerd" :: String
|
||||
|
||||
data Action
|
||||
= Initialize
|
||||
|
||||
| EventPageAuthentication PageAuthentication.Output
|
||||
data PageEvent
|
||||
= EventPageAuthentication PageAuthentication.Output
|
||||
| EventPageRegistration PageRegistration.Output
|
||||
| EventPageMailValidation PageMailValidation.Output
|
||||
| EventPageSetup PageSetup.Output
|
||||
|
|
@ -126,9 +124,19 @@ data Action
|
|||
| EventPageZone PageZone.Output
|
||||
| EventPageMigration PageMigration.Output
|
||||
|
||||
| EventWSAuthenticationDaemon WS.Output
|
||||
data NetworkEvent
|
||||
= EventWSAuthenticationDaemon WS.Output
|
||||
| EventWSDNSmanagerd WS.Output
|
||||
|
||||
data Action
|
||||
= Initialize
|
||||
|
||||
-- | When an event occurs on a page (including the navigation bar).
|
||||
| EventOnPage PageEvent
|
||||
|
||||
-- | When an event occurs on the network (web-socket related events).
|
||||
| EventOnNetwork NetworkEvent
|
||||
|
||||
-- | Disconnect from both `authd` and `dnsmanagerd` (remove sockets),
|
||||
-- | then return to the home page.
|
||||
| Disconnection
|
||||
|
|
@ -136,31 +144,9 @@ data Action
|
|||
-- | Reconnection to both `authd` and `dnsmanagerd`.
|
||||
| Reconnection
|
||||
|
||||
-- | Try to authenticate the user to `dnsmanagerd`.
|
||||
| AuthenticateToDNSManager
|
||||
|
||||
| AuthenticateToAuthd (Either Token LogInfo)
|
||||
|
||||
-- | Change the displayed page.
|
||||
| Routing Page
|
||||
|
||||
-- | `DecodeDNSMessage`: decode received `dnsmanagerd` messages into `DNSManager.AnswerMessage`,
|
||||
-- | then provide it to `DispatchDNSMessage`.
|
||||
| DecodeDNSMessage ArrayBuffer
|
||||
|
||||
-- | `DispatchDNSMessage`: send the DNS message to the right component.
|
||||
-- | The DNS message (from `dnsmanagerd`) was first received and decoded through the `DecodeDNSMessage` action.
|
||||
| DispatchDNSMessage DNSManager.AnswerMessage
|
||||
|
||||
-- | `DecodeAuthMessage`: decode received `authd` messages into ``, then provide
|
||||
-- | Then, the message is provided to the `DispatchAuthDaemonMessage` action (when needed).
|
||||
| DecodeAuthMessage ArrayBuffer
|
||||
|
||||
-- | DispatchAuthDaemonMessage: an auth daemon message (from `authd`) was received and decoded through the
|
||||
-- | `DecodeAuthMessage` action.
|
||||
-- | The message is provided to the right component.
|
||||
| DispatchAuthDaemonMessage AuthD.AnswerMessage
|
||||
|
||||
-- | Log message (through the Log component).
|
||||
| Log LogMessage
|
||||
|
||||
|
|
@ -295,7 +281,6 @@ render state
|
|||
]
|
||||
]
|
||||
where
|
||||
|
||||
website_hero :: forall w i. HH.HTML w i
|
||||
website_hero =
|
||||
HH.section [ HP.classes [C.hero, C.is_info, C.is_small] ]
|
||||
|
|
@ -335,10 +320,10 @@ render state
|
|||
then HH.div_ []
|
||||
else Web.btn_ [C.is_large, C.is_danger] "You have been disconnected. Click here to reconnect." Reconnection
|
||||
render_auth_WS :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad
|
||||
render_auth_WS = HH.slot _ws_auth unit WS.component (Tuple wsURLauthd "authd") EventWSAuthenticationDaemon
|
||||
render_auth_WS = HH.slot _ws_auth unit WS.component (Tuple wsURLauthd "authd") (EventOnNetwork <<< EventWSAuthenticationDaemon)
|
||||
|
||||
render_dnsmanager_WS :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad
|
||||
render_dnsmanager_WS = HH.slot _ws_dns unit WS.component (Tuple wsURLdnsmanagerd "dnsmanagerd") EventWSDNSmanagerd
|
||||
render_dnsmanager_WS = HH.slot _ws_dns unit WS.component (Tuple wsURLdnsmanagerd "dnsmanagerd") (EventOnNetwork <<< EventWSDNSmanagerd)
|
||||
|
||||
render_notifications =
|
||||
case state.notif of
|
||||
|
|
@ -349,24 +334,24 @@ render state
|
|||
render_home :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad
|
||||
render_home = HH.slot_ _ho unit PageHome.component unit
|
||||
render_domainlist_interface :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad
|
||||
render_domainlist_interface = HH.slot _dli unit PageDomainList.component unit EventPageDomainList
|
||||
render_domainlist_interface = HH.slot _dli unit PageDomainList.component unit (EventOnPage <<< EventPageDomainList)
|
||||
render_auth_form :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad
|
||||
render_auth_form = HH.slot _ai unit PageAuthentication.component unit EventPageAuthentication
|
||||
render_auth_form = HH.slot _ai unit PageAuthentication.component unit (EventOnPage <<< EventPageAuthentication)
|
||||
render_registration :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad
|
||||
render_registration = HH.slot _ri unit PageRegistration.component unit EventPageRegistration
|
||||
render_registration = HH.slot _ri unit PageRegistration.component unit (EventOnPage <<< EventPageRegistration)
|
||||
render_setup :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad
|
||||
render_setup = case state.user_data of
|
||||
Just user_data -> HH.slot _setupi unit PageSetup.component user_data EventPageSetup
|
||||
Just user_data -> HH.slot _setupi unit PageSetup.component user_data (EventOnPage <<< EventPageSetup)
|
||||
Nothing -> Web.p "You shouldn't see this page. Please, reconnect."
|
||||
render_mail_validation :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad
|
||||
render_mail_validation = HH.slot _mvi unit PageMailValidation.component unit EventPageMailValidation
|
||||
render_mail_validation = HH.slot _mvi unit PageMailValidation.component unit (EventOnPage <<< EventPageMailValidation)
|
||||
render_zone :: forall monad. String -> MonadAff monad => H.ComponentHTML Action ChildSlots monad
|
||||
render_zone domain = HH.slot _zi unit PageZone.component domain EventPageZone
|
||||
render_zone domain = HH.slot _zi unit PageZone.component domain (EventOnPage <<< EventPageZone)
|
||||
render_authd_admin_interface :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad
|
||||
render_authd_admin_interface = HH.slot _admini unit PageAdministration.component unit EventPageAdministration
|
||||
render_authd_admin_interface = HH.slot _admini unit PageAdministration.component unit (EventOnPage <<< EventPageAdministration)
|
||||
|
||||
render_migration :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad
|
||||
render_migration = HH.slot _mi unit PageMigration.component unit EventPageMigration
|
||||
render_migration = HH.slot _mi unit PageMigration.component unit (EventOnPage <<< EventPageMigration)
|
||||
|
||||
render_legal_notice :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad
|
||||
render_legal_notice
|
||||
|
|
@ -375,7 +360,7 @@ render state
|
|||
]
|
||||
|
||||
render_nav :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad
|
||||
render_nav = HH.slot _nav unit PageNavigation.component unit EventPageNavigation
|
||||
render_nav = HH.slot _nav unit PageNavigation.component unit (EventOnPage <<< EventPageNavigation)
|
||||
|
||||
render_logs :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad
|
||||
render_logs = Web.container [ HH.slot_ _log unit AppLog.component unit ]
|
||||
|
|
@ -477,30 +462,35 @@ handleAction = case _ of
|
|||
else do -- handleAction $ Log $ SystemLog "KeepAlive message from WS while connection was closed."
|
||||
pure unit
|
||||
|
||||
AuthenticateToAuthd v -> case v of
|
||||
Left token -> do
|
||||
handleAction $ Log $ SystemLog "Authenticate to authd with a token."
|
||||
message <- H.liftEffect $ AuthD.serialize $ AuthD.MkAuthByToken { token }
|
||||
H.tell _ws_auth unit (WS.ToSend message)
|
||||
Right (Tuple login password) -> do
|
||||
message <- H.liftEffect $ AuthD.serialize $ AuthD.MkLogin { login, password }
|
||||
H.tell _ws_auth unit (WS.ToSend message)
|
||||
EventOnPage page_event -> act_on_page_event page_event
|
||||
EventOnNetwork network_event -> act_on_network_event network_event
|
||||
|
||||
AuthenticateToDNSManager -> do
|
||||
state <- H.get
|
||||
case state.token of
|
||||
Just token -> do
|
||||
message <- H.liftEffect $ DNSManager.serialize $ DNSManager.MkLogin { token: token }
|
||||
H.tell _ws_dns unit (WS.ToSend message)
|
||||
Nothing -> do
|
||||
sessionstorage <- H.liftEffect $ Window.sessionStorage =<< HTML.window
|
||||
token <- H.liftEffect $ Storage.getItem "user-authd-token" sessionstorage
|
||||
case token of
|
||||
Nothing -> pure unit
|
||||
Just t -> do
|
||||
H.modify_ _ { token = Just t }
|
||||
handleAction AuthenticateToDNSManager
|
||||
AddNotif n -> H.modify_ _ { notif = n }
|
||||
CloseNotif -> H.modify_ _ { notif = NoNotification }
|
||||
|
||||
Reconnection -> do
|
||||
H.tell _ws_auth unit WS.Connect
|
||||
H.tell _ws_dns unit WS.Connect
|
||||
H.modify_ _ { notif = NoNotification }
|
||||
|
||||
Disconnection -> do
|
||||
handleAction $ Routing Home
|
||||
|
||||
-- Preserve the state of the connection (authd and dnsmanagerd).
|
||||
old_state <- H.get
|
||||
H.put $ initialState unit
|
||||
H.modify_ _ { are_we_connected_to_authd = old_state.are_we_connected_to_authd
|
||||
, are_we_connected_to_dnsmanagerd = old_state.are_we_connected_to_dnsmanagerd
|
||||
}
|
||||
|
||||
handleAction $ ToggleAuthenticated Nothing
|
||||
|
||||
-- Remove all stored session data.
|
||||
sessionstorage <- H.liftEffect $ Window.sessionStorage =<< HTML.window
|
||||
H.liftEffect $ Storage.clear sessionstorage
|
||||
|
||||
act_on_page_event :: forall o monad. MonadAff monad => PageEvent -> H.HalogenM State Action ChildSlots o monad Unit
|
||||
act_on_page_event page_event = case page_event of
|
||||
EventPageNavigation ev -> case ev of
|
||||
PageNavigation.Log message -> handleAction $ Log message
|
||||
PageNavigation.Routing page -> handleAction $ Routing page
|
||||
|
|
@ -523,7 +513,7 @@ handleAction = case _ of
|
|||
, new_password: pass }
|
||||
H.tell _ws_auth unit (WS.ToSend message)
|
||||
|
||||
PageAuthentication.AuthenticateToAuthd v -> handleAction $ AuthenticateToAuthd (Right v)
|
||||
PageAuthentication.AuthenticateToAuthd v -> authenticate_to_authd (Right v)
|
||||
PageAuthentication.Log message -> handleAction $ Log message
|
||||
PageAuthentication.UserLogin login -> do
|
||||
sessionstorage <- H.liftEffect $ Window.sessionStorage =<< HTML.window
|
||||
|
|
@ -564,7 +554,6 @@ handleAction = case _ of
|
|||
, email: Nothing
|
||||
}
|
||||
H.tell _ws_auth unit (WS.ToSend message)
|
||||
|
||||
PageSetup.Log message -> handleAction $ Log message
|
||||
|
||||
EventPageAdministration ev -> case ev of
|
||||
|
|
@ -648,189 +637,6 @@ handleAction = case _ of
|
|||
state <- H.get
|
||||
H.tell _dli unit (PageDomainList.ProvideState state.childstates.domainlist)
|
||||
|
||||
-- | `authd websocket component` wants to do something.
|
||||
EventWSAuthenticationDaemon ev -> case ev of
|
||||
WS.MessageReceived (Tuple _ message) -> handleAction $ DecodeAuthMessage message
|
||||
|
||||
WS.WSJustConnected -> do
|
||||
H.modify_ _ { are_we_connected_to_authd = true }
|
||||
sessionstorage <- H.liftEffect $ Window.sessionStorage =<< HTML.window
|
||||
token <- H.liftEffect $ Storage.getItem "user-authd-token" sessionstorage
|
||||
case token of
|
||||
Nothing -> pure unit
|
||||
Just t -> do
|
||||
handleAction $ Log $ SystemLog "Let's authenticate to authd"
|
||||
handleAction $ AuthenticateToAuthd (Left t)
|
||||
|
||||
WS.WSJustClosed -> do
|
||||
H.modify_ _ { are_we_connected_to_dnsmanagerd = false }
|
||||
H.liftEffect scrollToTop
|
||||
-- handleAction $ Log $ ErrorLog "You just got disconnected from authd."
|
||||
WS.Log message -> handleAction $ Log message
|
||||
WS.KeepAlive -> handleAction $ KeepAlive $ Left unit
|
||||
|
||||
WS.ResetKeepAliveCounter -> handleAction ResetKeepAliveCounter
|
||||
|
||||
DecodeAuthMessage message -> do
|
||||
receivedMessage <- H.liftEffect $ AuthD.deserialize message
|
||||
case receivedMessage of
|
||||
-- Cases where we didn't understand the message.
|
||||
Left err -> do
|
||||
-- handleAction $ Log $ ErrorLog $
|
||||
-- "received a message that couldn't be decoded. Reason: " <> show err
|
||||
case err of
|
||||
(AuthD.JSONERROR jerr) -> do
|
||||
-- print_json_string messageEvent.message
|
||||
handleAction $ Log $ ErrorLog $ "JSON parsing error: " <> jerr
|
||||
(AuthD.UnknownError unerr) -> handleAction $ Log $ ErrorLog $
|
||||
"Parsing error: AuthD.UnknownError" <> (show unerr)
|
||||
(AuthD.UnknownNumber ) -> handleAction $ Log $ ErrorLog
|
||||
"Parsing error: AuthD.UnknownNumber"
|
||||
|
||||
-- Cases where we understood the message.
|
||||
-- TODO: create a modal to show some of these?
|
||||
Right response -> do
|
||||
case response of
|
||||
(AuthD.GotUser _) -> do
|
||||
handleAction $ Log $ ErrorLog "TODO: received a GotUser message."
|
||||
m@(AuthD.GotUserAdded _) -> do
|
||||
{ current_page } <- H.get
|
||||
case current_page of
|
||||
Registration -> do
|
||||
let successlog = """
|
||||
You are now registered. Please verify your email address with the token we have sent you.
|
||||
"""
|
||||
handleAction $ Log $ SuccessLog successlog
|
||||
handleAction $ AddNotif $ GoodNotification successlog
|
||||
handleAction $ Routing MailValidation
|
||||
_ -> handleAction $ DispatchAuthDaemonMessage m
|
||||
(AuthD.GotUserEdited u) -> do
|
||||
handleAction $ Log $ SuccessLog $ "User (" <> show u.uid <> ") was modified."
|
||||
handleAction $ AddNotif $ GoodNotification "Modification done."
|
||||
(AuthD.GotUserValidated _) -> do
|
||||
handleAction $ Log $ SuccessLog "User got validated. You can now log in."
|
||||
handleAction $ Routing Authentication
|
||||
handleAction $ AddNotif $ GoodNotification "User got validated. You can now log in."
|
||||
(AuthD.GotUsersList _) -> do
|
||||
handleAction $ Log $ ErrorLog "TODO: received a GotUsersList message."
|
||||
(AuthD.GotPermissionCheck _) -> do
|
||||
handleAction $ Log $ ErrorLog "TODO: received a GotPermissionCheck message."
|
||||
(AuthD.GotPermissionSet _) -> do
|
||||
handleAction $ Log $ ErrorLog "Received a GotPermissionSet message."
|
||||
(AuthD.GotErrorEmailAddressNotValidated _) -> do
|
||||
handleAction $ Log $ ErrorLog """
|
||||
Cannot authenticate: your email address hasn't been validated.
|
||||
Please check your email inbox.
|
||||
"""
|
||||
m@(AuthD.GotPasswordRecovered _) -> do
|
||||
handleAction $ Log $ SuccessLog "your new password is now valid."
|
||||
handleAction $ DispatchAuthDaemonMessage m
|
||||
handleAction $ AddNotif $ GoodNotification "Your new password is now valid."
|
||||
m@(AuthD.GotMatchingUsers _) -> do
|
||||
{ current_page } <- H.get
|
||||
case current_page of
|
||||
Administration -> handleAction $ DispatchAuthDaemonMessage m
|
||||
_ -> handleAction $ Log $ ErrorLog
|
||||
"received a GotMatchingUsers message while not on authd admin page."
|
||||
m@(AuthD.GotUserDeleted _) -> do
|
||||
{ current_page } <- H.get
|
||||
case current_page of
|
||||
Administration -> handleAction $ DispatchAuthDaemonMessage m
|
||||
_ -> pure unit
|
||||
(AuthD.GotNewEmailTokenSent _) -> do
|
||||
handleAction $ Log $ SuccessLog "New email address is pending. Please enter validation token."
|
||||
(AuthD.GotNewEmailAddressValidated msg) -> do
|
||||
handleAction $ Log $ SuccessLog "New email address has been validated."
|
||||
handleAction $ AddNotif $ GoodNotification "Your new email address is now valid."
|
||||
H.modify_ _ { user_data = Just (Tuple (Just msg.email) Nothing) }
|
||||
handleAction $ Routing DomainList
|
||||
(AuthD.GotErrorMustBeAuthenticated _) -> do
|
||||
handleAction $ Log $ ErrorLog "received a GotErrorMustBeAuthenticated message."
|
||||
handleAction $ AddNotif $ BadNotification "Sorry, you must be authenticated to perform this action."
|
||||
(AuthD.GotErrorAlreadyUsedLogin _) -> do
|
||||
handleAction $ Log $ ErrorLog "received a GotErrorAlreadyUsedLogin message."
|
||||
handleAction $ AddNotif $ BadNotification "Sorry, this login is already used."
|
||||
H.liftEffect scrollToTop
|
||||
(AuthD.GotErrorEmailAddressAlreadyUsed _) -> do
|
||||
handleAction $ Log $ ErrorLog "received a GotErrorEmailAddressAlreadyUsed message."
|
||||
handleAction $ AddNotif $ BadNotification "Sorry, this email address is already used."
|
||||
H.liftEffect scrollToTop
|
||||
(AuthD.GotErrorUserNotFound _) -> do
|
||||
handleAction $ Log $ ErrorLog "received a GotErrorUserNotFound message."
|
||||
handleAction $ AddNotif $ BadNotification "User hasn't been found."
|
||||
|
||||
-- The authentication failed.
|
||||
(AuthD.GotError errmsg) -> do
|
||||
handleAction $ Log $ ErrorLog $ " generic error message: "
|
||||
<> maybe "server didn't tell why" (\v -> v) errmsg.reason
|
||||
handleAction $ AddNotif $ BadNotification $ "Sorry, authd sent an error message. "
|
||||
<> maybe "The server didn't tell why." (\v -> "Message was: " <> v) errmsg.reason
|
||||
m@(AuthD.GotPasswordRecoverySent _) -> do
|
||||
handleAction $ Log $ SuccessLog $ "Password recovery: email sent."
|
||||
handleAction $ AddNotif $ GoodNotification "Your password recovery mail has been sent."
|
||||
handleAction $ DispatchAuthDaemonMessage m
|
||||
(AuthD.GotErrorPasswordTooShort _) -> do
|
||||
handleAction $ Log $ ErrorLog "Password too short."
|
||||
handleAction $ AddNotif $ BadNotification "Your password is too short."
|
||||
(AuthD.GotErrorMailRequired _) -> do
|
||||
handleAction $ Log $ ErrorLog "Email required."
|
||||
handleAction $ AddNotif $ BadNotification "An email is required."
|
||||
(AuthD.GotErrorInvalidCredentials _) -> do
|
||||
handleAction $ Log $ ErrorLog "Invalid credentials."
|
||||
handleAction $ ToggleAuthenticated Nothing
|
||||
handleAction $ AddNotif $ BadNotification "Invalid credentials."
|
||||
(AuthD.GotErrorRegistrationsClosed _) -> do
|
||||
handleAction $ Log $ ErrorLog "Registration closed. Try another time or contact an administrator."
|
||||
handleAction $ AddNotif $ BadNotification "Registration are closed at the moment."
|
||||
(AuthD.GotErrorInvalidLoginFormat _) -> do
|
||||
handleAction $ Log $ ErrorLog "Invalid login format."
|
||||
handleAction $ AddNotif $ BadNotification "Invalid login format."
|
||||
(AuthD.GotErrorInvalidEmailFormat _) -> do
|
||||
handleAction $ Log $ ErrorLog "Invalid email format."
|
||||
handleAction $ AddNotif $ BadNotification "Invalid email format."
|
||||
(AuthD.GotErrorAlreadyUsersInDB _) -> do
|
||||
handleAction $ Log $ ErrorLog "Login already taken."
|
||||
handleAction $ AddNotif $ BadNotification "Login already taken."
|
||||
(AuthD.GotErrorReadOnlyProfileKeys _) -> do
|
||||
handleAction $ Log $ ErrorLog "Trying to add a profile with some invalid (read-only) keys."
|
||||
handleAction $ AddNotif $ BadNotification "Trying to add a profile with some invalid (read-only) keys."
|
||||
(AuthD.GotErrorInvalidActivationKey _) -> do
|
||||
handleAction $ Log $ ErrorLog "Invalid activation key."
|
||||
handleAction $ AddNotif $ BadNotification "Invalid activation key."
|
||||
(AuthD.GotErrorUserAlreadyValidated _) -> do
|
||||
handleAction $ Log $ ErrorLog "User already validated."
|
||||
handleAction $ AddNotif $ BadNotification "User already validated."
|
||||
(AuthD.GotErrorCannotContactUser _) -> do
|
||||
handleAction $ Log $ ErrorLog "User cannot be contacted. Email address may be invalid."
|
||||
handleAction $ AddNotif $ BadNotification "User cannot be contacted. Email address may be invalid."
|
||||
(AuthD.GotErrorInvalidRenewKey _) -> do
|
||||
handleAction $ Log $ ErrorLog "Invalid renew key."
|
||||
handleAction $ AddNotif $ BadNotification "Invalid renew key."
|
||||
(AuthD.GotErrorPasswordTooLong _) -> do
|
||||
handleAction $ Log $ ErrorLog "Password too long."
|
||||
handleAction $ AddNotif $ BadNotification "Password too long."
|
||||
-- The authentication was a success!
|
||||
(AuthD.GotToken msg) -> do
|
||||
handleAction $ Log $ SuccessLog $ "Authenticated to authd."
|
||||
H.modify_ _ { token = Just msg.token
|
||||
, user_data = Just (Tuple msg.current_email msg.pending_email)
|
||||
}
|
||||
handleAction $ ToggleAuthenticated (Just msg.token)
|
||||
|
||||
sessionstorage <- H.liftEffect $ Window.sessionStorage =<< HTML.window
|
||||
_ <- H.liftEffect $ Storage.setItem "user-authd-token" msg.token sessionstorage
|
||||
|
||||
handleAction AuthenticateToDNSManager
|
||||
|
||||
-- In case the account doesn't have a valid email address, the user
|
||||
-- shouldn't be able to do anything else than to add their address.
|
||||
case msg.current_email of
|
||||
Nothing -> handleAction $ Routing Migration
|
||||
_ -> pure unit
|
||||
|
||||
(AuthD.GotKeepAlive _) -> pure unit
|
||||
pure unit
|
||||
|
||||
EventPageMigration ev -> case ev of
|
||||
PageMigration.AskNewEmailAddress email -> do
|
||||
message <- H.liftEffect $ AuthD.serialize $ AuthD.MkNewEmailAddress { email }
|
||||
|
|
@ -840,8 +646,209 @@ handleAction = case _ of
|
|||
H.tell _ws_auth unit (WS.ToSend message)
|
||||
PageMigration.Log message -> handleAction $ Log message
|
||||
|
||||
-- | Send a received authentication daemon message `AuthD.AnswerMessage` to a component.
|
||||
DispatchAuthDaemonMessage message -> do
|
||||
act_on_network_event :: forall o monad. MonadAff monad => NetworkEvent -> H.HalogenM State Action ChildSlots o monad Unit
|
||||
act_on_network_event network_event = case network_event of
|
||||
-- | `authd websocket component` wants to do something.
|
||||
EventWSAuthenticationDaemon ev -> case ev of
|
||||
WS.MessageReceived (Tuple _ message) -> decode_message_from_authd message
|
||||
WS.WSJustConnected -> do
|
||||
H.modify_ _ { are_we_connected_to_authd = true }
|
||||
sessionstorage <- H.liftEffect $ Window.sessionStorage =<< HTML.window
|
||||
token <- H.liftEffect $ Storage.getItem "user-authd-token" sessionstorage
|
||||
case token of
|
||||
Nothing -> pure unit
|
||||
Just t -> do
|
||||
handleAction $ Log $ SystemLog "Let's authenticate to authd"
|
||||
authenticate_to_authd (Left t)
|
||||
WS.WSJustClosed -> do
|
||||
H.modify_ _ { are_we_connected_to_dnsmanagerd = false }
|
||||
H.liftEffect scrollToTop
|
||||
-- handleAction $ Log $ ErrorLog "You just got disconnected from authd."
|
||||
WS.Log message -> handleAction $ Log message
|
||||
WS.KeepAlive -> handleAction $ KeepAlive $ Left unit
|
||||
WS.ResetKeepAliveCounter -> handleAction ResetKeepAliveCounter
|
||||
|
||||
-- | `dnsmanagerd websocket component` wants to do something.
|
||||
EventWSDNSmanagerd ev -> case ev of
|
||||
WS.MessageReceived (Tuple _ message) -> decode_message_from_dnsmanagerd message
|
||||
WS.WSJustConnected -> do
|
||||
H.modify_ _ { are_we_connected_to_dnsmanagerd = true }
|
||||
authenticate_to_dnsmanagerd
|
||||
WS.WSJustClosed -> do
|
||||
H.modify_ _ { are_we_connected_to_dnsmanagerd = false }
|
||||
H.liftEffect scrollToTop
|
||||
-- handleAction $ Log $ ErrorLog "You just got disconnected from dnsmanagerd."
|
||||
WS.Log message -> handleAction $ Log message
|
||||
WS.KeepAlive -> handleAction $ KeepAlive $ Right unit
|
||||
WS.ResetKeepAliveCounter -> handleAction ResetKeepAliveCounter
|
||||
|
||||
|
||||
-- | Decode received `authd` messages into ``, then provide
|
||||
-- | The message can be forwarded to a component when needed.
|
||||
decode_message_from_authd :: forall o monad. MonadAff monad => ArrayBuffer -> H.HalogenM State Action ChildSlots o monad Unit
|
||||
decode_message_from_authd arraybuffer = do
|
||||
receivedMessage <- H.liftEffect $ AuthD.deserialize arraybuffer
|
||||
case receivedMessage of
|
||||
-- Cases where we didn't understand the message.
|
||||
Left err -> do
|
||||
-- handleAction $ Log $ ErrorLog $
|
||||
-- "received a message that couldn't be decoded. Reason: " <> show err
|
||||
case err of
|
||||
(AuthD.JSONERROR jerr) -> do
|
||||
-- print_json_string messageEvent.message
|
||||
handleAction $ Log $ ErrorLog $ "JSON parsing error: " <> jerr
|
||||
(AuthD.UnknownError unerr) -> handleAction $ Log $ ErrorLog $
|
||||
"Parsing error: AuthD.UnknownError" <> (show unerr)
|
||||
(AuthD.UnknownNumber ) -> handleAction $ Log $ ErrorLog
|
||||
"Parsing error: AuthD.UnknownNumber"
|
||||
|
||||
-- Cases where we understood the message.
|
||||
-- TODO: create a modal to show some of these?
|
||||
Right response -> do
|
||||
case response of
|
||||
(AuthD.GotUser _) -> do
|
||||
handleAction $ Log $ ErrorLog "TODO: received a GotUser message."
|
||||
m@(AuthD.GotUserAdded _) -> do
|
||||
{ current_page } <- H.get
|
||||
case current_page of
|
||||
Registration -> do
|
||||
let successlog = """
|
||||
You are now registered. Please verify your email address with the token we have sent you.
|
||||
"""
|
||||
handleAction $ Log $ SuccessLog successlog
|
||||
handleAction $ AddNotif $ GoodNotification successlog
|
||||
handleAction $ Routing MailValidation
|
||||
_ -> forward m
|
||||
(AuthD.GotUserEdited u) -> do
|
||||
handleAction $ Log $ SuccessLog $ "User (" <> show u.uid <> ") was modified."
|
||||
handleAction $ AddNotif $ GoodNotification "Modification done."
|
||||
(AuthD.GotUserValidated _) -> do
|
||||
handleAction $ Log $ SuccessLog "User got validated. You can now log in."
|
||||
handleAction $ Routing Authentication
|
||||
handleAction $ AddNotif $ GoodNotification "User got validated. You can now log in."
|
||||
(AuthD.GotUsersList _) -> do
|
||||
handleAction $ Log $ ErrorLog "TODO: received a GotUsersList message."
|
||||
(AuthD.GotPermissionCheck _) -> do
|
||||
handleAction $ Log $ ErrorLog "TODO: received a GotPermissionCheck message."
|
||||
(AuthD.GotPermissionSet _) -> do
|
||||
handleAction $ Log $ ErrorLog "Received a GotPermissionSet message."
|
||||
(AuthD.GotErrorEmailAddressNotValidated _) -> do
|
||||
handleAction $ Log $ ErrorLog """
|
||||
Cannot authenticate: your email address hasn't been validated.
|
||||
Please check your email inbox.
|
||||
"""
|
||||
m@(AuthD.GotPasswordRecovered _) -> do
|
||||
handleAction $ Log $ SuccessLog "your new password is now valid."
|
||||
forward m
|
||||
handleAction $ AddNotif $ GoodNotification "Your new password is now valid."
|
||||
m@(AuthD.GotMatchingUsers _) -> do
|
||||
{ current_page } <- H.get
|
||||
case current_page of
|
||||
Administration -> forward m
|
||||
_ -> handleAction $ Log $ ErrorLog
|
||||
"received a GotMatchingUsers message while not on authd admin page."
|
||||
m@(AuthD.GotUserDeleted _) -> do
|
||||
{ current_page } <- H.get
|
||||
case current_page of
|
||||
Administration -> forward m
|
||||
_ -> pure unit
|
||||
(AuthD.GotNewEmailTokenSent _) -> do
|
||||
handleAction $ Log $ SuccessLog "New email address is pending. Please enter validation token."
|
||||
(AuthD.GotNewEmailAddressValidated msg) -> do
|
||||
handleAction $ Log $ SuccessLog "New email address has been validated."
|
||||
handleAction $ AddNotif $ GoodNotification "Your new email address is now valid."
|
||||
H.modify_ _ { user_data = Just (Tuple (Just msg.email) Nothing) }
|
||||
handleAction $ Routing DomainList
|
||||
(AuthD.GotErrorMustBeAuthenticated _) -> do
|
||||
handleAction $ Log $ ErrorLog "received a GotErrorMustBeAuthenticated message."
|
||||
handleAction $ AddNotif $ BadNotification "Sorry, you must be authenticated to perform this action."
|
||||
(AuthD.GotErrorAlreadyUsedLogin _) -> do
|
||||
handleAction $ Log $ ErrorLog "received a GotErrorAlreadyUsedLogin message."
|
||||
handleAction $ AddNotif $ BadNotification "Sorry, this login is already used."
|
||||
H.liftEffect scrollToTop
|
||||
(AuthD.GotErrorEmailAddressAlreadyUsed _) -> do
|
||||
handleAction $ Log $ ErrorLog "received a GotErrorEmailAddressAlreadyUsed message."
|
||||
handleAction $ AddNotif $ BadNotification "Sorry, this email address is already used."
|
||||
H.liftEffect scrollToTop
|
||||
(AuthD.GotErrorUserNotFound _) -> do
|
||||
handleAction $ Log $ ErrorLog "received a GotErrorUserNotFound message."
|
||||
handleAction $ AddNotif $ BadNotification "User hasn't been found."
|
||||
|
||||
-- The authentication failed.
|
||||
(AuthD.GotError errmsg) -> do
|
||||
handleAction $ Log $ ErrorLog $ " generic error message: "
|
||||
<> maybe "server didn't tell why" (\v -> v) errmsg.reason
|
||||
handleAction $ AddNotif $ BadNotification $ "Sorry, authd sent an error message. "
|
||||
<> maybe "The server didn't tell why." (\v -> "Message was: " <> v) errmsg.reason
|
||||
m@(AuthD.GotPasswordRecoverySent _) -> do
|
||||
handleAction $ Log $ SuccessLog $ "Password recovery: email sent."
|
||||
handleAction $ AddNotif $ GoodNotification "Your password recovery mail has been sent."
|
||||
forward m
|
||||
(AuthD.GotErrorPasswordTooShort _) -> do
|
||||
handleAction $ Log $ ErrorLog "Password too short."
|
||||
handleAction $ AddNotif $ BadNotification "Your password is too short."
|
||||
(AuthD.GotErrorMailRequired _) -> do
|
||||
handleAction $ Log $ ErrorLog "Email required."
|
||||
handleAction $ AddNotif $ BadNotification "An email is required."
|
||||
(AuthD.GotErrorInvalidCredentials _) -> do
|
||||
handleAction $ Log $ ErrorLog "Invalid credentials."
|
||||
handleAction $ ToggleAuthenticated Nothing
|
||||
handleAction $ AddNotif $ BadNotification "Invalid credentials."
|
||||
(AuthD.GotErrorRegistrationsClosed _) -> do
|
||||
handleAction $ Log $ ErrorLog "Registration closed. Try another time or contact an administrator."
|
||||
handleAction $ AddNotif $ BadNotification "Registration are closed at the moment."
|
||||
(AuthD.GotErrorInvalidLoginFormat _) -> do
|
||||
handleAction $ Log $ ErrorLog "Invalid login format."
|
||||
handleAction $ AddNotif $ BadNotification "Invalid login format."
|
||||
(AuthD.GotErrorInvalidEmailFormat _) -> do
|
||||
handleAction $ Log $ ErrorLog "Invalid email format."
|
||||
handleAction $ AddNotif $ BadNotification "Invalid email format."
|
||||
(AuthD.GotErrorAlreadyUsersInDB _) -> do
|
||||
handleAction $ Log $ ErrorLog "Login already taken."
|
||||
handleAction $ AddNotif $ BadNotification "Login already taken."
|
||||
(AuthD.GotErrorReadOnlyProfileKeys _) -> do
|
||||
handleAction $ Log $ ErrorLog "Trying to add a profile with some invalid (read-only) keys."
|
||||
handleAction $ AddNotif $ BadNotification "Trying to add a profile with some invalid (read-only) keys."
|
||||
(AuthD.GotErrorInvalidActivationKey _) -> do
|
||||
handleAction $ Log $ ErrorLog "Invalid activation key."
|
||||
handleAction $ AddNotif $ BadNotification "Invalid activation key."
|
||||
(AuthD.GotErrorUserAlreadyValidated _) -> do
|
||||
handleAction $ Log $ ErrorLog "User already validated."
|
||||
handleAction $ AddNotif $ BadNotification "User already validated."
|
||||
(AuthD.GotErrorCannotContactUser _) -> do
|
||||
handleAction $ Log $ ErrorLog "User cannot be contacted. Email address may be invalid."
|
||||
handleAction $ AddNotif $ BadNotification "User cannot be contacted. Email address may be invalid."
|
||||
(AuthD.GotErrorInvalidRenewKey _) -> do
|
||||
handleAction $ Log $ ErrorLog "Invalid renew key."
|
||||
handleAction $ AddNotif $ BadNotification "Invalid renew key."
|
||||
(AuthD.GotErrorPasswordTooLong _) -> do
|
||||
handleAction $ Log $ ErrorLog "Password too long."
|
||||
handleAction $ AddNotif $ BadNotification "Password too long."
|
||||
-- The authentication was a success!
|
||||
(AuthD.GotToken msg) -> do
|
||||
handleAction $ Log $ SuccessLog $ "Authenticated to authd."
|
||||
H.modify_ _ { token = Just msg.token
|
||||
, user_data = Just (Tuple msg.current_email msg.pending_email)
|
||||
}
|
||||
handleAction $ ToggleAuthenticated (Just msg.token)
|
||||
|
||||
sessionstorage <- H.liftEffect $ Window.sessionStorage =<< HTML.window
|
||||
_ <- H.liftEffect $ Storage.setItem "user-authd-token" msg.token sessionstorage
|
||||
|
||||
authenticate_to_dnsmanagerd
|
||||
|
||||
-- In case the account doesn't have a valid email address, the user
|
||||
-- shouldn't be able to do anything else than to add their address.
|
||||
case msg.current_email of
|
||||
Nothing -> handleAction $ Routing Migration
|
||||
_ -> pure unit
|
||||
|
||||
(AuthD.GotKeepAlive _) -> pure unit
|
||||
pure unit
|
||||
where
|
||||
-- | Send a received authentication daemon message `App.Message.AuthenticationDaemon.AnswerMessage` to a component.
|
||||
-- forward :: AuthD.AnswerMessage
|
||||
forward message = do
|
||||
{ current_page } <- H.get
|
||||
case current_page of
|
||||
Authentication -> H.tell _ai unit (PageAuthentication.MessageReceived message)
|
||||
|
|
@ -849,169 +856,129 @@ handleAction = case _ of
|
|||
_ -> handleAction $ Log $ SystemLog "unexpected message from authd"
|
||||
pure unit
|
||||
|
||||
AddNotif n -> H.modify_ _ { notif = n }
|
||||
CloseNotif -> H.modify_ _ { notif = NoNotification }
|
||||
|
||||
Reconnection -> do
|
||||
H.tell _ws_auth unit WS.Connect
|
||||
H.tell _ws_dns unit WS.Connect
|
||||
H.modify_ _ { notif = NoNotification }
|
||||
|
||||
Disconnection -> do
|
||||
handleAction $ Routing Home
|
||||
|
||||
-- Preserve the state of the connection (authd and dnsmanagerd).
|
||||
old_state <- H.get
|
||||
H.put $ initialState unit
|
||||
H.modify_ _ { are_we_connected_to_authd = old_state.are_we_connected_to_authd
|
||||
, are_we_connected_to_dnsmanagerd = old_state.are_we_connected_to_dnsmanagerd
|
||||
}
|
||||
|
||||
handleAction $ ToggleAuthenticated Nothing
|
||||
|
||||
-- Remove all stored session data.
|
||||
sessionstorage <- H.liftEffect $ Window.sessionStorage =<< HTML.window
|
||||
H.liftEffect $ Storage.clear sessionstorage
|
||||
|
||||
-- | `dnsmanagerd websocket component` wants to do something.
|
||||
EventWSDNSmanagerd ev -> case ev of
|
||||
WS.MessageReceived (Tuple _ message) -> handleAction $ DecodeDNSMessage message
|
||||
WS.WSJustConnected -> do
|
||||
H.modify_ _ { are_we_connected_to_dnsmanagerd = true }
|
||||
handleAction AuthenticateToDNSManager
|
||||
WS.WSJustClosed -> do
|
||||
H.modify_ _ { are_we_connected_to_dnsmanagerd = false }
|
||||
H.liftEffect scrollToTop
|
||||
-- handleAction $ Log $ ErrorLog "You just got disconnected from dnsmanagerd."
|
||||
WS.Log message -> handleAction $ Log message
|
||||
WS.KeepAlive -> handleAction $ KeepAlive $ Right unit
|
||||
|
||||
WS.ResetKeepAliveCounter -> handleAction ResetKeepAliveCounter
|
||||
|
||||
-- | `DecodeDNSMessage`: decode a received `dnsmanagerd` message, then transfer it to `DispatchDNSMessage`.
|
||||
DecodeDNSMessage message -> do
|
||||
receivedMessage <- H.liftEffect $ DNSManager.deserialize message
|
||||
case receivedMessage of
|
||||
-- Cases where we didn't understand the message.
|
||||
Left err -> do
|
||||
-- handleAction $ Log $ ErrorLog $
|
||||
-- "received a message that couldn't be decoded. Reason: " <> show err
|
||||
case err of
|
||||
(DNSManager.JSONERROR jerr) -> do
|
||||
handleAction $ Log $ ErrorLog $ "JSON parsing error: " <> jerr
|
||||
(DNSManager.UnknownError unerr) ->
|
||||
handleAction $ Log $ ErrorLog $ "Parsing error: DNSManager.UnknownError" <> (show unerr)
|
||||
(DNSManager.UnknownNumber ) ->
|
||||
handleAction $ Log $ ErrorLog $ "Parsing error: DNSManager.UnknownNumber"
|
||||
|
||||
-- Cases where we understood the message.
|
||||
Right received_msg -> do
|
||||
case received_msg of
|
||||
(DNSManager.MkDomainNotFound _) -> do
|
||||
handleAction $ Log $ ErrorLog $ "DomainNotFound"
|
||||
handleAction $ AddNotif $ BadNotification $ "The domain doesn't exist."
|
||||
(DNSManager.MkRRNotFound _) -> do
|
||||
handleAction $ Log $ ErrorLog $ "RRNotFound"
|
||||
handleAction $ AddNotif $ BadNotification $ "The resource record doesn't exist."
|
||||
(DNSManager.MkInvalidZone _) -> do
|
||||
handleAction $ Log $ ErrorLog $ "InvalidZone"
|
||||
handleAction $ AddNotif $ BadNotification $ "The domain zone is invalid."
|
||||
m@(DNSManager.MkDomainChanged response) -> do
|
||||
handleAction $ Log $ SystemLog $ "Domain \"" <> response.domain.name <> "\" has been updated."
|
||||
handleAction $ DispatchDNSMessage m
|
||||
(DNSManager.MkUnknownZone _) -> do
|
||||
handleAction $ Log $ ErrorLog $ "UnknownZone"
|
||||
handleAction $ AddNotif $ BadNotification $ "The domain zone is unknown."
|
||||
(DNSManager.MkDomainList _) -> do
|
||||
handleAction $ Log $ ErrorLog $ "MkDomainList"
|
||||
(DNSManager.MkUnknownUser _) -> do
|
||||
handleAction $ Log $ ErrorLog $ "MkUnknownUser"
|
||||
(DNSManager.MkNoOwnership _) -> do
|
||||
handleAction $ Log $ ErrorLog $ "MkNoOwnership"
|
||||
handleAction $ AddNotif $ BadNotification $ "You don't own this domain."
|
||||
(DNSManager.MkInsufficientRights _) -> do
|
||||
handleAction $ Log $ ErrorLog $ "You do not have sufficient rights."
|
||||
handleAction $ AddNotif $ BadNotification $ "You do not have sufficient rights."
|
||||
-- The authentication failed.
|
||||
(DNSManager.MkError errmsg) -> do
|
||||
handleAction $ Log $ ErrorLog errmsg.reason
|
||||
(DNSManager.MkErrorUserNotLogged _) -> do
|
||||
handleAction $ Log $ ErrorLog $ "The user isn't connected."
|
||||
handleAction $ Log $ SystemLog $ "Trying to authenticate to fix the problem..."
|
||||
handleAction AuthenticateToDNSManager
|
||||
(DNSManager.MkErrorInvalidToken _) -> do
|
||||
H.modify_ _ { token = Nothing, current_page = Home }
|
||||
handleAction $ Log $ ErrorLog $ "Invalid token. Try re-authenticate."
|
||||
-- TODO: should we disconnect from authd?
|
||||
handleAction $ ToggleAuthenticated Nothing
|
||||
(DNSManager.MkDomainAlreadyExists _) -> do
|
||||
handleAction $ Log $ ErrorLog $ "The domain already exists."
|
||||
handleAction $ AddNotif $ BadNotification $ "The domain already exists."
|
||||
m@(DNSManager.MkUnacceptableDomain _) -> do
|
||||
handleAction $ Log $ ErrorLog $ "Domain not acceptable (see accepted domain list)."
|
||||
handleAction $ DispatchDNSMessage m
|
||||
m@(DNSManager.MkAcceptedDomains _) -> do
|
||||
handleAction $ Log $ SuccessLog $ "Received the list of accepted domains."
|
||||
handleAction $ DispatchDNSMessage m
|
||||
m@(DNSManager.MkLogged logged_message) -> do
|
||||
handleAction $ Log $ SuccessLog $ "Authenticated to dnsmanagerd."
|
||||
H.tell _nav unit $ PageNavigation.ToggleAdmin logged_message.admin
|
||||
handleAction $ AddNotif $ GoodNotification "You are now authenticated."
|
||||
handleAction $ DispatchDNSMessage m
|
||||
m@(DNSManager.MkDomainAdded response) -> do
|
||||
handleAction $ Log $ SuccessLog $ "Domain added: " <> response.domain
|
||||
handleAction $ AddNotif $ GoodNotification $ "You have just registered the domain \""
|
||||
<> response.domain <> "\". 🥳 You can now manage it (click on its button)."
|
||||
handleAction $ DispatchDNSMessage m
|
||||
(DNSManager.MkRRReadOnly response) -> do
|
||||
handleAction $ Log $ ErrorLog $ "Trying to modify a read-only resource. "
|
||||
<> "domain: " <> response.domain
|
||||
<> "resource rrid: " <> show response.rr.rrid
|
||||
m@(DNSManager.MkRRUpdated _) -> do
|
||||
handleAction $ Log $ SuccessLog $ "Resource updated."
|
||||
handleAction $ DispatchDNSMessage m
|
||||
m@(DNSManager.MkRRAdded response) -> do
|
||||
handleAction $ Log $ SuccessLog $ "Resource Record added: " <> response.rr.rrtype
|
||||
handleAction $ DispatchDNSMessage m
|
||||
m@(DNSManager.MkGeneratedZoneFile response) -> do
|
||||
handleAction $ Log $ SuccessLog $ "Received zonefile for " <> response.domain
|
||||
handleAction $ DispatchDNSMessage m
|
||||
(DNSManager.MkInvalidDomainName _) -> do
|
||||
handleAction $ Log $ ErrorLog $ "The domain is not valid."
|
||||
handleAction $ AddNotif $ BadNotification $ "Invalid domain name."
|
||||
m@(DNSManager.MkDomainDeleted response) -> do
|
||||
let successlog = "The domain \"" <> response.domain <> "\" has been deleted."
|
||||
handleAction $ Log $ SuccessLog successlog
|
||||
handleAction $ AddNotif $ GoodNotification successlog
|
||||
handleAction $ DispatchDNSMessage m
|
||||
m@(DNSManager.MkRRDeleted response) -> do
|
||||
handleAction $ Log $ SuccessLog $ "Resource record (rrid: \"" <> show response.rrid <> "\") has been deleted."
|
||||
handleAction $ DispatchDNSMessage m
|
||||
m@(DNSManager.MkZone _) -> do
|
||||
handleAction $ Log $ SuccessLog $ "Zone received."
|
||||
handleAction $ DispatchDNSMessage m
|
||||
(DNSManager.MkInvalidRR response) -> do
|
||||
let errorlog = "Invalid resource record: " <> A.intercalate ", " response.errors
|
||||
handleAction $ Log $ ErrorLog errorlog
|
||||
handleAction $ AddNotif $ BadNotification errorlog
|
||||
(DNSManager.MkSuccess _) -> do
|
||||
handleAction $ Log $ SuccessLog $ "(generic) Success."
|
||||
DNSManager.MkOrphanDomainList response -> do
|
||||
handleAction $ Log $ SuccessLog "Received orphan domain list."
|
||||
H.tell _admini unit (PageAdministration.GotOrphanDomainList response.domains)
|
||||
DNSManager.MkFoundDomains response -> do
|
||||
handleAction $ Log $ SuccessLog "Received found domain list."
|
||||
H.tell _admini unit (PageAdministration.GotFoundDomains response.domains)
|
||||
(DNSManager.GotKeepAlive _) -> do
|
||||
-- handleAction $ Log $ SystemLog $ "KeepAlive."
|
||||
pure unit
|
||||
pure unit
|
||||
|
||||
-- | Send a received DNS manager message to a component.
|
||||
-- | TODO: in case the message is a `logged` message, it means that the connection has been reset, and should be
|
||||
-- | handled no matter the actual page we're on.
|
||||
DispatchDNSMessage message -> do
|
||||
-- | Decode received `dnsmanagerd` messages into `DNSManager.AnswerMessage`.
|
||||
-- | Messages can be forwarded to components.
|
||||
decode_message_from_dnsmanagerd :: forall o monad. MonadAff monad => ArrayBuffer -> H.HalogenM State Action ChildSlots o monad Unit
|
||||
decode_message_from_dnsmanagerd arraybuffer = do
|
||||
receivedMessage <- H.liftEffect $ DNSManager.deserialize arraybuffer
|
||||
case receivedMessage of
|
||||
-- Cases where we didn't understand the message.
|
||||
Left err -> do
|
||||
-- handleAction $ Log $ ErrorLog $
|
||||
-- "received a message that couldn't be decoded. Reason: " <> show err
|
||||
case err of
|
||||
(DNSManager.JSONERROR jerr) -> do
|
||||
handleAction $ Log $ ErrorLog $ "JSON parsing error: " <> jerr
|
||||
(DNSManager.UnknownError unerr) ->
|
||||
handleAction $ Log $ ErrorLog $ "Parsing error: DNSManager.UnknownError" <> (show unerr)
|
||||
(DNSManager.UnknownNumber ) ->
|
||||
handleAction $ Log $ ErrorLog $ "Parsing error: DNSManager.UnknownNumber"
|
||||
|
||||
-- Cases where we understood the message.
|
||||
Right received_msg -> do
|
||||
case received_msg of
|
||||
(DNSManager.MkDomainNotFound _) -> do
|
||||
handleAction $ Log $ ErrorLog $ "DomainNotFound"
|
||||
handleAction $ AddNotif $ BadNotification $ "The domain doesn't exist."
|
||||
(DNSManager.MkRRNotFound _) -> do
|
||||
handleAction $ Log $ ErrorLog $ "RRNotFound"
|
||||
handleAction $ AddNotif $ BadNotification $ "The resource record doesn't exist."
|
||||
(DNSManager.MkInvalidZone _) -> do
|
||||
handleAction $ Log $ ErrorLog $ "InvalidZone"
|
||||
handleAction $ AddNotif $ BadNotification $ "The domain zone is invalid."
|
||||
m@(DNSManager.MkDomainChanged response) -> do
|
||||
handleAction $ Log $ SystemLog $ "Domain \"" <> response.domain.name <> "\" has been updated."
|
||||
forward m
|
||||
(DNSManager.MkUnknownZone _) -> do
|
||||
handleAction $ Log $ ErrorLog $ "UnknownZone"
|
||||
handleAction $ AddNotif $ BadNotification $ "The domain zone is unknown."
|
||||
(DNSManager.MkDomainList _) -> do
|
||||
handleAction $ Log $ ErrorLog $ "MkDomainList"
|
||||
(DNSManager.MkUnknownUser _) -> do
|
||||
handleAction $ Log $ ErrorLog $ "MkUnknownUser"
|
||||
(DNSManager.MkNoOwnership _) -> do
|
||||
handleAction $ Log $ ErrorLog $ "MkNoOwnership"
|
||||
handleAction $ AddNotif $ BadNotification $ "You don't own this domain."
|
||||
(DNSManager.MkInsufficientRights _) -> do
|
||||
handleAction $ Log $ ErrorLog $ "You do not have sufficient rights."
|
||||
handleAction $ AddNotif $ BadNotification $ "You do not have sufficient rights."
|
||||
-- The authentication failed.
|
||||
(DNSManager.MkError errmsg) -> do
|
||||
handleAction $ Log $ ErrorLog errmsg.reason
|
||||
(DNSManager.MkErrorUserNotLogged _) -> do
|
||||
handleAction $ Log $ ErrorLog $ "The user isn't connected."
|
||||
handleAction $ Log $ SystemLog $ "Trying to authenticate to fix the problem..."
|
||||
authenticate_to_dnsmanagerd
|
||||
(DNSManager.MkErrorInvalidToken _) -> do
|
||||
H.modify_ _ { token = Nothing, current_page = Home }
|
||||
handleAction $ Log $ ErrorLog $ "Invalid token. Try re-authenticate."
|
||||
-- TODO: should we disconnect from authd?
|
||||
handleAction $ ToggleAuthenticated Nothing
|
||||
(DNSManager.MkDomainAlreadyExists _) -> do
|
||||
handleAction $ Log $ ErrorLog $ "The domain already exists."
|
||||
handleAction $ AddNotif $ BadNotification $ "The domain already exists."
|
||||
m@(DNSManager.MkUnacceptableDomain _) -> do
|
||||
handleAction $ Log $ ErrorLog $ "Domain not acceptable (see accepted domain list)."
|
||||
forward m
|
||||
m@(DNSManager.MkAcceptedDomains _) -> do
|
||||
handleAction $ Log $ SuccessLog $ "Received the list of accepted domains."
|
||||
forward m
|
||||
m@(DNSManager.MkLogged logged_message) -> do
|
||||
handleAction $ Log $ SuccessLog $ "Authenticated to dnsmanagerd."
|
||||
H.tell _nav unit $ PageNavigation.ToggleAdmin logged_message.admin
|
||||
handleAction $ AddNotif $ GoodNotification "You are now authenticated."
|
||||
forward m
|
||||
m@(DNSManager.MkDomainAdded response) -> do
|
||||
handleAction $ Log $ SuccessLog $ "Domain added: " <> response.domain
|
||||
handleAction $ AddNotif $ GoodNotification $ "You have just registered the domain \""
|
||||
<> response.domain <> "\". 🥳 You can now manage it (click on its button)."
|
||||
forward m
|
||||
(DNSManager.MkRRReadOnly response) -> do
|
||||
handleAction $ Log $ ErrorLog $ "Trying to modify a read-only resource. "
|
||||
<> "domain: " <> response.domain
|
||||
<> "resource rrid: " <> show response.rr.rrid
|
||||
m@(DNSManager.MkRRUpdated _) -> do
|
||||
handleAction $ Log $ SuccessLog $ "Resource updated."
|
||||
forward m
|
||||
m@(DNSManager.MkRRAdded response) -> do
|
||||
handleAction $ Log $ SuccessLog $ "Resource Record added: " <> response.rr.rrtype
|
||||
forward m
|
||||
m@(DNSManager.MkGeneratedZoneFile response) -> do
|
||||
handleAction $ Log $ SuccessLog $ "Received zonefile for " <> response.domain
|
||||
forward m
|
||||
(DNSManager.MkInvalidDomainName _) -> do
|
||||
handleAction $ Log $ ErrorLog $ "The domain is not valid."
|
||||
handleAction $ AddNotif $ BadNotification $ "Invalid domain name."
|
||||
m@(DNSManager.MkDomainDeleted response) -> do
|
||||
let successlog = "The domain \"" <> response.domain <> "\" has been deleted."
|
||||
handleAction $ Log $ SuccessLog successlog
|
||||
handleAction $ AddNotif $ GoodNotification successlog
|
||||
forward m
|
||||
m@(DNSManager.MkRRDeleted response) -> do
|
||||
handleAction $ Log $ SuccessLog $ "Resource record (rrid: \"" <> show response.rrid <> "\") has been deleted."
|
||||
forward m
|
||||
m@(DNSManager.MkZone _) -> do
|
||||
handleAction $ Log $ SuccessLog $ "Zone received."
|
||||
forward m
|
||||
(DNSManager.MkInvalidRR response) -> do
|
||||
let errorlog = "Invalid resource record: " <> A.intercalate ", " response.errors
|
||||
handleAction $ Log $ ErrorLog errorlog
|
||||
handleAction $ AddNotif $ BadNotification errorlog
|
||||
(DNSManager.MkSuccess _) -> do
|
||||
handleAction $ Log $ SuccessLog $ "(generic) Success."
|
||||
DNSManager.MkOrphanDomainList response -> do
|
||||
handleAction $ Log $ SuccessLog "Received orphan domain list."
|
||||
H.tell _admini unit (PageAdministration.GotOrphanDomainList response.domains)
|
||||
DNSManager.MkFoundDomains response -> do
|
||||
handleAction $ Log $ SuccessLog "Received found domain list."
|
||||
H.tell _admini unit (PageAdministration.GotFoundDomains response.domains)
|
||||
(DNSManager.GotKeepAlive _) -> do
|
||||
-- handleAction $ Log $ SystemLog $ "KeepAlive."
|
||||
pure unit
|
||||
pure unit
|
||||
where
|
||||
-- | Send a received dnsmanager daemon message `App.Message.DNSManagerDaemon.AnswerMessage` to a component.
|
||||
forward message = do
|
||||
-- The message `Logged` can be received after a re-connection (typically, after a page reload).
|
||||
-- This is an hint, and the application should do a series of actions based on this.
|
||||
-- First, we should check if there is a "current page", if so, switch page.
|
||||
|
|
@ -1036,7 +1003,7 @@ handleAction = case _ of
|
|||
Zone _ , _ -> H.tell _zi unit (PageZone.MessageReceived message)
|
||||
_, _ -> handleAction $ Log $ SystemLog "unexpected message from dnsmanagerd"
|
||||
pure unit
|
||||
where
|
||||
|
||||
update_domain_list state m = do
|
||||
case state.childstates.domainlist of
|
||||
Nothing -> do
|
||||
|
|
@ -1044,34 +1011,54 @@ handleAction = case _ of
|
|||
H.modify_ _ { childstates { domainlist = Just new_value } }
|
||||
Just _ -> pure unit
|
||||
|
||||
revert_old_page = do
|
||||
-- Get back to the previous page.
|
||||
sessionstorage <- H.liftEffect $ Window.sessionStorage =<< HTML.window
|
||||
page <- H.liftEffect $ Storage.getItem "current-page" sessionstorage
|
||||
case page of
|
||||
Nothing -> pure unit
|
||||
Just "Home" -> handleAction $ Routing Home
|
||||
Just "Authentication" -> handleAction $ Routing Authentication
|
||||
Just "Registration" -> handleAction $ Routing Registration
|
||||
Just "DomainList" -> handleAction $ Routing DomainList
|
||||
Just "MailValidation" -> handleAction $ Routing MailValidation
|
||||
Just "Setup" -> handleAction $ Routing Setup
|
||||
Just "Administration" -> handleAction $ Routing Administration
|
||||
Just "LegalNotice" -> handleAction $ Routing LegalNotice
|
||||
Just "Migration" -> handleAction $ Routing Migration
|
||||
Just "Zone" -> do
|
||||
domain <- H.liftEffect $ Storage.getItem "current-zone" sessionstorage
|
||||
case domain of
|
||||
Nothing -> handleAction $ Log $ SystemLog "Zone but no domain recorded!! WEIRD"
|
||||
Just zone -> do handleAction $ Log $ SystemLog $ "zone to display: " <> zone
|
||||
handleAction $ Routing (Zone zone)
|
||||
Just p -> handleAction $ Log $ SystemLog $ "Oopsie, we didn't understand the old page: " <> p
|
||||
revert_old_page :: forall o monad. MonadAff monad => H.HalogenM State Action ChildSlots o monad Unit
|
||||
revert_old_page = do
|
||||
-- Get back to the previous page.
|
||||
sessionstorage <- H.liftEffect $ Window.sessionStorage =<< HTML.window
|
||||
page <- H.liftEffect $ Storage.getItem "current-page" sessionstorage
|
||||
case page of
|
||||
Nothing -> pure unit
|
||||
Just "Home" -> handleAction $ Routing Home
|
||||
Just "Authentication" -> handleAction $ Routing Authentication
|
||||
Just "Registration" -> handleAction $ Routing Registration
|
||||
Just "DomainList" -> handleAction $ Routing DomainList
|
||||
Just "MailValidation" -> handleAction $ Routing MailValidation
|
||||
Just "Setup" -> handleAction $ Routing Setup
|
||||
Just "Administration" -> handleAction $ Routing Administration
|
||||
Just "LegalNotice" -> handleAction $ Routing LegalNotice
|
||||
Just "Migration" -> handleAction $ Routing Migration
|
||||
Just "Zone" -> do
|
||||
domain <- H.liftEffect $ Storage.getItem "current-zone" sessionstorage
|
||||
case domain of
|
||||
Nothing -> handleAction $ Log $ SystemLog "Zone but no domain recorded!! WEIRD"
|
||||
Just zone -> do handleAction $ Log $ SystemLog $ "zone to display: " <> zone
|
||||
handleAction $ Routing (Zone zone)
|
||||
Just p -> handleAction $ Log $ SystemLog $ "Oopsie, we didn't understand the old page: " <> p
|
||||
|
||||
-- | Try to authenticate the user to `dnsmanagerd`.
|
||||
authenticate_to_dnsmanagerd :: forall o monad. MonadAff monad => H.HalogenM State Action ChildSlots o monad Unit
|
||||
authenticate_to_dnsmanagerd = do
|
||||
state <- H.get
|
||||
case state.token of
|
||||
Just token -> do
|
||||
message <- H.liftEffect $ DNSManager.serialize $ DNSManager.MkLogin { token: token }
|
||||
H.tell _ws_dns unit (WS.ToSend message)
|
||||
Nothing -> do
|
||||
sessionstorage <- H.liftEffect $ Window.sessionStorage =<< HTML.window
|
||||
token <- H.liftEffect $ Storage.getItem "user-authd-token" sessionstorage
|
||||
case token of
|
||||
Nothing -> pure unit
|
||||
Just t -> do
|
||||
H.modify_ _ { token = Just t }
|
||||
authenticate_to_dnsmanagerd
|
||||
|
||||
--print_json_string :: forall m. MonadEffect m => MonadState State m => ArrayBuffer -> m Unit
|
||||
--print_json_string arraybuffer = do
|
||||
-- -- fromTypedIPC :: ArrayBuffer -> Effect (Either ParseError (Tuple UInt String))
|
||||
-- value <- H.liftEffect $ IPC.fromTypedIPC arraybuffer
|
||||
-- H.raise $ Log $ ErrorLog $ case (value) of
|
||||
-- Left _ -> "Cannot even fromTypedIPC the message."
|
||||
-- Right (Tuple messageTypeNumber string) -> "Number is: " <> show messageTypeNumber <> ", received string: " <> string
|
||||
authenticate_to_authd :: forall o monad.
|
||||
MonadAff monad => (Either Token LogInfo) -> H.HalogenM State Action ChildSlots o monad Unit
|
||||
authenticate_to_authd v = case v of
|
||||
Left token -> do
|
||||
handleAction $ Log $ SystemLog "Authenticate to authd with a token."
|
||||
message <- H.liftEffect $ AuthD.serialize $ AuthD.MkAuthByToken { token }
|
||||
H.tell _ws_auth unit (WS.ToSend message)
|
||||
Right (Tuple login password) -> do
|
||||
message <- H.liftEffect $ AuthD.serialize $ AuthD.MkLogin { login, password }
|
||||
H.tell _ws_auth unit (WS.ToSend message)
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue