From 999d801eafe9bf47984c0fe55cec3f542e993002 Mon Sep 17 00:00:00 2001 From: Philippe Pittoli Date: Fri, 16 May 2025 04:11:17 +0200 Subject: [PATCH] Refactoring of Container: split code into multiple functions (WIP). --- src/App/Container.purs | 869 ++++++++++++++++++++--------------------- 1 file changed, 428 insertions(+), 441 deletions(-) diff --git a/src/App/Container.purs b/src/App/Container.purs index 38b0c20..cdf57b7 100644 --- a/src/App/Container.purs +++ b/src/App/Container.purs @@ -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)