From 66820d0dd4c042e3dbc7c409d094ea884a4a1426 Mon Sep 17 00:00:00 2001 From: Philippe Pittoli Date: Fri, 23 Feb 2024 19:04:04 +0100 Subject: [PATCH] New Setup page, to handle user account administration. --- src/App/Container.purs | 43 +++++++--- src/App/NavigationInterface.purs | 8 +- src/App/Pages.purs | 1 + src/App/Setup.purs | 138 +++++++++++++++++++++++++++++++ src/CSSClasses.purs | 2 + 5 files changed, 176 insertions(+), 16 deletions(-) create mode 100644 src/App/Setup.purs diff --git a/src/App/Container.purs b/src/App/Container.purs index b77990f..4f6a0ec 100644 --- a/src/App/Container.purs +++ b/src/App/Container.purs @@ -58,7 +58,8 @@ import App.RegistrationInterface as RI import App.MailValidationInterface as MVI import App.Log as AppLog import App.WS as WS -import App.AdministrationInterface as AdminI +import App.AdministrationInterface as AdminInterface +import App.SetupInterface as SetupInterface import App.DomainListInterface as DomainListInterface import App.ZoneInterface as ZoneInterface import App.HomeInterface as HomeInterface @@ -96,11 +97,14 @@ data Action -- | Handle events from `MailValidationInterface`. | MailValidationInterfaceEvent MVI.Output + -- | Handle events from `SetupInterface`. + | SetupInterfaceEvent SetupInterface.Output + -- | Handle events from `NavigationInterface`. | NavigationInterfaceEvent NavigationInterface.Output -- | Handle events from `AuthenticationDaemonAdminComponent`. - | AdministrationEvent AdminI.Output -- Administration interface. + | AdministrationEvent AdminInterface.Output -- Administration interface. -- | Handle events from `DomainListComponent`. | DomainListComponentEvent DomainListInterface.Output @@ -161,7 +165,7 @@ data Action type State = { token :: Maybe String , current_page :: Page , store_DomainListInterface_state :: Maybe DomainListInterface.State - , store_AuthenticationDaemonAdmin_state :: Maybe AdminI.State + , store_AuthenticationDaemonAdmin_state :: Maybe AdminInterface.State } -- | The list of child components: log, `WS` twice (once for each ws connection), @@ -176,7 +180,8 @@ type ChildSlots = , ai :: AI.Slot Unit , ri :: RI.Slot Unit , mvi :: MVI.Slot Unit - , admini :: AdminI.Slot Unit + , admini :: AdminInterface.Slot Unit + , setupi :: SetupInterface.Slot Unit , dli :: DomainListInterface.Slot Unit , zi :: ZoneInterface.Slot Unit ) @@ -190,6 +195,7 @@ _ai = Proxy :: Proxy "ai" -- Authentication Interface _ri = Proxy :: Proxy "ri" -- Registration Interface _mvi = Proxy :: Proxy "mvi" -- Mail Validation Interface _admini = Proxy :: Proxy "admini" -- Administration Interface +_setupi = Proxy :: Proxy "setupi" -- Setup Interface _dli = Proxy :: Proxy "dli" -- Domain List _zi = Proxy :: Proxy "zi" -- Zone Interface @@ -221,6 +227,7 @@ render state MailValidation -> render_mail_validation DomainList -> render_domainlist_interface Zone domain -> render_zone domain + Setup -> render_setup Administration -> render_authd_admin_interface -- The footer includes logs and both the WS child components. , Bulma.columns_ [ Bulma.column_ [ render_logs ] @@ -236,12 +243,16 @@ render state render_auth_form = HH.slot _ai unit AI.component unit AuthenticationInterfaceEvent render_registration :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad render_registration = HH.slot _ri unit RI.component unit RegistrationInterfaceEvent + render_setup :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad + render_setup = case state.token of + Just token -> HH.slot _setupi unit SetupInterface.component token SetupInterfaceEvent + Nothing -> Bulma.p "You shouldn't see this page. Reconnect!" render_mail_validation :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad render_mail_validation = HH.slot _mvi unit MVI.component unit MailValidationInterfaceEvent render_zone :: forall monad. String -> MonadAff monad => H.ComponentHTML Action ChildSlots monad render_zone domain = HH.slot _zi unit ZoneInterface.component domain ZoneInterfaceEvent render_authd_admin_interface :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad - render_authd_admin_interface = HH.slot _admini unit AdminI.component unit AdministrationEvent + render_authd_admin_interface = HH.slot _admini unit AdminInterface.component unit AdministrationEvent render_nav :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad render_nav = HH.slot _nav unit NavigationInterface.component unit NavigationInterfaceEvent @@ -281,6 +292,7 @@ handleAction = case _ of DomainList -> H.liftEffect $ Storage.setItem "current-page" "DomainList" sessionstorage Zone zone -> do _ <- H.liftEffect $ Storage.setItem "current-page" "Zone" sessionstorage H.liftEffect $ Storage.setItem "current-zone" zone sessionstorage + Setup -> H.liftEffect $ Storage.setItem "current-page" "Setup" sessionstorage Administration -> H.liftEffect $ Storage.setItem "current-page" "Administration" sessionstorage H.modify_ _ { current_page = page } @@ -340,13 +352,17 @@ handleAction = case _ of MVI.MessageToSend message -> H.tell _ws_auth unit (WS.ToSend message) MVI.Log message -> H.tell _log unit (AppLog.Log message) + SetupInterfaceEvent ev -> case ev of + SetupInterface.ChangePassword pass -> handleAction $ Log $ ErrorLog "TODO: change password" + SetupInterface.Log message -> H.tell _log unit (AppLog.Log message) + AdministrationEvent ev -> case ev of - AdminI.MessageToSend message -> H.tell _ws_auth unit (WS.ToSend message) - AdminI.Log message -> H.tell _log unit (AppLog.Log message) - AdminI.StoreState s -> H.modify_ _ { store_AuthenticationDaemonAdmin_state = Just s } - AdminI.AskState -> do + AdminInterface.MessageToSend message -> H.tell _ws_auth unit (WS.ToSend message) + AdminInterface.Log message -> H.tell _log unit (AppLog.Log message) + AdminInterface.StoreState s -> H.modify_ _ { store_AuthenticationDaemonAdmin_state = Just s } + AdminInterface.AskState -> do state <- H.get - H.tell _admini unit (AdminI.ProvideState state.store_AuthenticationDaemonAdmin_state) + H.tell _admini unit (AdminInterface.ProvideState state.store_AuthenticationDaemonAdmin_state) ZoneInterfaceEvent ev -> case ev of ZoneInterface.MessageToSend message -> H.tell _ws_dns unit (WS.ToSend message) @@ -370,7 +386,7 @@ handleAction = case _ of WS.WSJustConnected -> do H.tell _ai unit AI.ConnectionIsUp - H.tell _admini unit AdminI.ConnectionIsUp + H.tell _admini unit AdminInterface.ConnectionIsUp sessionstorage <- H.liftEffect $ Window.sessionStorage =<< HTML.window token <- H.liftEffect $ Storage.getItem "user-authd-token" sessionstorage case token of @@ -381,7 +397,7 @@ handleAction = case _ of WS.WSJustClosed -> do H.tell _ai unit AI.ConnectionIsDown - H.tell _admini unit AdminI.ConnectionIsDown + H.tell _admini unit AdminInterface.ConnectionIsDown WS.Log message -> H.tell _log unit (AppLog.Log message) WS.KeepAlive -> handleAction $ KeepAlive $ Left unit @@ -498,7 +514,7 @@ handleAction = case _ of DispatchAuthDaemonMessage message -> do { current_page } <- H.get case current_page of - Administration -> H.tell _admini unit (AdminI.MessageReceived message) + Administration -> H.tell _admini unit (AdminInterface.MessageReceived message) _ -> handleAction $ Log $ SystemLog "unexpected message from authd" pure unit @@ -660,6 +676,7 @@ handleAction = case _ of 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 "Zone" -> do domain <- H.liftEffect $ Storage.getItem "current-zone" sessionstorage diff --git a/src/App/NavigationInterface.purs b/src/App/NavigationInterface.purs index 36a109c..80b8dbf 100644 --- a/src/App/NavigationInterface.purs +++ b/src/App/NavigationInterface.purs @@ -90,7 +90,7 @@ handleQuery = case _ of -- | -- | On mobile (a device with low resolution), a `burger icon` appears instead of the navigation bar. -- | When clicked, a list of options (such as pages or a disconnection button) should appear. --- | Also, when clicked again, the list should disappear. +-- | Also, when clicked again, the list disappears. render :: forall m. State -> H.ComponentHTML Action () m render { logged, active, admin } = @@ -112,7 +112,7 @@ render { logged, active, admin } = right_bar_div = case logged of false -> [ link_auth, link_register, link_mail_validation ] - _ -> [ link_disconnection ] + _ -> [ link_setup, link_disconnection ] navbar_color = C.is_success @@ -122,7 +122,7 @@ render { logged, active, admin } = , ARIA.role "navigation" ] - logo = HH.strong [HP.classes $ C.navbar_item <> (C.is_size 4)] [HH.text "🍉"] + logo = HH.strong [HP.classes $ C.navbar_item <> (C.is_size 4)] [HH.text "🔻🍉"] -- HH.a [HP.classes C.navbar_item, HP.href "/"] -- [HH.img [HP.src "/logo.jpeg", HP.width 112, HP.height 28]] @@ -152,6 +152,7 @@ render { logged, active, admin } = link_auth = nav_link "Login" (Navigate Authentication) link_register = nav_link_strong "Register" (Navigate Registration) link_mail_validation = nav_link "Mail verification" (Navigate MailValidation) + link_setup = nav_link_warn "⚒ Setup" (Navigate Setup) link_disconnection = nav_link_ (C.has_text_light <> C.has_background_danger) "Disconnection" UnLog @@ -171,6 +172,7 @@ render { logged, active, admin } = ] [ (HH.strong [] [ HH.text str ]) ] nav_link str action = nav_link_ navbar_color str action + nav_link_warn str action = nav_link_ (C.has_background_warning <> C.has_text_dark) str action nav_link_ classes str action = HH.a [ HP.classes (C.navbar_item <> classes) diff --git a/src/App/Pages.purs b/src/App/Pages.purs index cf1aea4..fbd6fd3 100644 --- a/src/App/Pages.purs +++ b/src/App/Pages.purs @@ -9,4 +9,5 @@ data Page | MailValidation -- | `MailValidation`: to validate email addresses (via a token). | DomainList -- | `DomainList`: to list owned domains and to ask for new domains. | Zone String -- | `Zone`: to manage a zone. + | Setup -- | `Setup`: user account administration page | Administration -- | `Administration`: administration page (for both `authd` and `dnsmanagerd`). diff --git a/src/App/Setup.purs b/src/App/Setup.purs new file mode 100644 index 0000000..dec043b --- /dev/null +++ b/src/App/Setup.purs @@ -0,0 +1,138 @@ +-- | `App.SetupInterface` allows users to change their password or their email address. +-- | Users can also erase their account. +module App.SetupInterface where + +import Prelude (Unit, bind, discard, pure, ($), (<<<), (<>), (==)) + +import Data.ArrayBuffer.Types (ArrayBuffer) +import Data.Maybe (Maybe(..)) +import Data.Tuple (Tuple(..)) +import Effect.Aff.Class (class MonadAff) +import Halogen as H +import Halogen.HTML as HH +import Halogen.HTML.Events as HE +import Halogen.HTML.Properties as HP +import Web.Event.Event as Event +import Web.Event.Event (Event) + +import Bulma as Bulma + +import App.Email as Email +import App.LogMessage +import App.Messages.AuthenticationDaemon as AuthD + +data Output + = Log LogMessage + | ChangePassword String + +-- | The component's parent provides received messages. +-- | +-- | Also, the component is informed when the connection went up or down. +data Query a + = MessageReceived AuthD.AnswerMessage a + | ConnectionIsDown a + | ConnectionIsUp a + +type Slot = H.Slot Query Output + +type Input = String + +data AuthenticationInput + = AUTH_INP_login String + | AUTH_INP_pass String + +data NewPasswordInput + = NEWPASS_INP_password String + | NEWPASS_INP_confirmation String + +data Action + = HandleNewPassword NewPasswordInput + | ChangePasswordAttempt Event + +type StateNewPasswordForm = { password :: String, confirmation :: String } + +type State = + { newPasswordForm :: StateNewPasswordForm + , token :: String + , wsUp :: Boolean + } + +component :: forall m. MonadAff m => H.Component Query Input Output m +component = + H.mkComponent + { initialState + , render + , eval: H.mkEval $ H.defaultEval + { handleAction = handleAction + , handleQuery = handleQuery + } + } + +initialState :: Input -> State +initialState token = + { newPasswordForm: { password: "", confirmation: "" } + , token + , wsUp: true + } + +render :: forall m. State -> H.ComponentHTML Action () m +render { wsUp, newPasswordForm } + = render_new_password_form + + where + should_be_disabled = (if wsUp then (HP.enabled true) else (HP.disabled true)) + render_new_password_form = HH.form + [ HE.onSubmit ChangePasswordAttempt ] + [ Bulma.box_input "passwordNEWPASS" "Password" "password" + (HandleNewPassword <<< NEWPASS_INP_password) + newPasswordForm.password + should_be_disabled + , Bulma.box_input "confirmationNEWPASS" "Confirmation" "confirmation" + (HandleNewPassword <<< NEWPASS_INP_confirmation) + newPasswordForm.confirmation + should_be_disabled + , HH.button + [ HP.style "padding: 0.5rem 1.25rem;" + , HP.type_ HP.ButtonSubmit + , (if wsUp then (HP.enabled true) else (HP.disabled true)) + ] + [ HH.text "Send Message to Server" ] + ] + +handleAction :: forall m. MonadAff m => Action -> H.HalogenM State Action () Output m Unit +handleAction = case _ of + HandleNewPassword authinp -> do + case authinp of + NEWPASS_INP_password v -> H.modify_ _ { newPasswordForm { password = v } } + NEWPASS_INP_confirmation v -> H.modify_ _ { newPasswordForm { confirmation = v } } + + ChangePasswordAttempt ev -> do + H.liftEffect $ Event.preventDefault ev + + { newPasswordForm } <- H.get + case newPasswordForm.password, newPasswordForm.confirmation of + "" , _ -> H.raise $ Log $ UnableToSend "Write your password!" + _ , "" -> H.raise $ Log $ UnableToSend "Confirm your password!" + pass, confirmation -> do + if pass == confirmation + then do H.raise $ Log $ SystemLog "Changing the password" + H.raise $ ChangePassword pass + else H.raise $ Log $ UnableToSend "Confirmation differs from password" + +handleQuery :: forall a m. MonadAff m => Query a -> H.HalogenM State Action () Output m (Maybe a) +handleQuery = case _ of + -- For now, no message actually needs to be handled here. + -- Error messages are simply logged (see the code in the Container component). + MessageReceived message _ -> do + case message of + _ -> do + H.raise $ Log $ ErrorLog $ "Message not handled in SetupInterface." + pure Nothing + + ConnectionIsDown a -> do + H.modify_ _ { wsUp = false } + pure (Just a) + + ConnectionIsUp a -> do + H.modify_ _ { wsUp = true } + pure (Just a) diff --git a/src/CSSClasses.purs b/src/CSSClasses.purs index 950aa66..ae9177e 100644 --- a/src/CSSClasses.purs +++ b/src/CSSClasses.purs @@ -91,6 +91,8 @@ has_background_warning_light = [HH.ClassName "has-background-warning-light"] has_background_danger_light :: Array HH.ClassName has_background_danger_light = [HH.ClassName "has-background-danger-light"] +has_text_dark :: Array HH.ClassName +has_text_dark = [HH.ClassName "has-text-dark"] has_text_light :: Array HH.ClassName has_text_light = [HH.ClassName "has-text-light"] has_succeeds_separator :: Array HH.ClassName