From 6c4ed85335ec24df7f5b9aee18f68368386f66d8 Mon Sep 17 00:00:00 2001 From: Philippe Pittoli Date: Thu, 22 Feb 2024 05:42:25 +0100 Subject: [PATCH] Navigation bar now has a dedicated component. --- src/App/Container.purs | 55 ++++++++-------- src/App/Nav.purs | 31 ++++----- src/App/NavigationInterface.purs | 104 +++++++++++++++++++++++++++++++ src/App/Pages.purs | 12 ++++ 4 files changed, 159 insertions(+), 43 deletions(-) create mode 100644 src/App/NavigationInterface.purs create mode 100644 src/App/Pages.purs diff --git a/src/App/Container.purs b/src/App/Container.purs index 39feba9..2ef2da6 100644 --- a/src/App/Container.purs +++ b/src/App/Container.purs @@ -49,8 +49,6 @@ import Prelude (Unit, bind, discard, unit, ($), (=<<), (<>), show, pure) import Bulma as Bulma -import App.Nav as Nav - import Data.Array as A import Data.Maybe (Maybe(..), maybe) import Data.Either (Either(..)) @@ -64,6 +62,7 @@ import App.AdministrationInterface as AdminI import App.DomainListInterface as DomainListInterface import App.ZoneInterface as ZoneInterface import App.HomeInterface as HomeInterface +import App.NavigationInterface as NavigationInterface import App.Messages.DNSManagerDaemon as DNSManager import App.Messages.AuthenticationDaemon as AuthD import Halogen as H @@ -78,17 +77,7 @@ import Web.Storage.Storage as Storage import App.LogMessage (LogMessage(..)) --- | This list will grow in a near future. --- | --- | TODO: -data Page - = Home -- | `Home`: presentation of the project. - | Authentication -- | `Authentication`: authentication page. - | Registration -- | `Registration`: to register new people. - | 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. - | Administration -- | `Administration`: administration page (for both `authd` and `dnsmanagerd`). +import App.Pages type Token = String type Login = String @@ -105,6 +94,9 @@ data Action -- | Handle events from `MailValidationInterface`. | MailValidationInterfaceEvent MVI.Output + -- | Handle events from `NavigationInterface`. + | NavigationInterfaceEvent NavigationInterface.Output + -- | Handle events from `AuthenticationDaemonAdminComponent`. | AdministrationEvent AdminI.Output -- Administration interface. @@ -155,6 +147,10 @@ data Action -- | `KeepAlive` send a keepalive message to either `authd` or `dnsmanagerd`. | KeepAlive (Either Unit Unit) + -- | `ToggleAuthenticated` performs some actions required when a connection or a disconnection occurs. + -- | Currently, this handles the navigation bar. + | ToggleAuthenticated (Maybe Token) + -- | The component's state is composed of: -- | a potential authentication token, -- | the current page, @@ -174,6 +170,7 @@ type ChildSlots = , ho :: HomeInterface.Slot Unit , ws_auth :: WS.Slot Unit , ws_dns :: WS.Slot Unit + , nav :: NavigationInterface.Slot Unit , ai :: AI.Slot Unit , ri :: RI.Slot Unit , mvi :: MVI.Slot Unit @@ -186,6 +183,7 @@ _ho = Proxy :: Proxy "ho" -- Home Interface _log = Proxy :: Proxy "log" -- Log _ws_auth = Proxy :: Proxy "ws_auth" -- WS with `authd` _ws_dns = Proxy :: Proxy "ws_dns" -- WS with `dnsmanagerd` +_nav = Proxy :: Proxy "nav" -- Navigation Interface _ai = Proxy :: Proxy "ai" -- Authentication Interface _ri = Proxy :: Proxy "ri" -- Registration Interface _mvi = Proxy :: Proxy "mvi" -- Mail Validation Interface @@ -243,27 +241,13 @@ render state 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 - authenticated = case state.token of - Nothing -> false - Just _ -> true - - -- TODO: this is needed to show the authd admin button - admin = true - render_nav :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad - render_nav = Nav.netlibre_navbar authenticated admin - (Routing Home) - (Routing DomainList) - (Routing Administration) - (Routing Authentication) - (Routing Registration) - (Routing MailValidation) - Disconnection + render_nav = HH.slot _nav unit NavigationInterface.component unit NavigationInterfaceEvent render_header :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad render_header = case state.token of Nothing -> Bulma.hero "net libre" "free domains" - Just _ -> Bulma.hero "net libre" "free domains" + Just _ -> Bulma.hero "net libre" "" render_logs :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad render_logs = Bulma.container [ HH.slot_ _log unit AppLog.component unit ] @@ -292,6 +276,10 @@ handleAction = case _ of Log message -> H.tell _log unit $ AppLog.Log message + ToggleAuthenticated maybe_token -> case maybe_token of + Nothing -> H.tell _nav unit $ NavigationInterface.ToggleLogged false + Just _ -> H.tell _nav unit $ NavigationInterface.ToggleLogged true + KeepAlive auth_or_dnsmanager -> case auth_or_dnsmanager of Left _ -> do message <- H.liftEffect $ AuthD.serialize $ AuthD.MkKeepAlive {} @@ -324,6 +312,11 @@ handleAction = case _ of H.modify_ _ { token = Just t } handleAction AuthenticateToDNSManager + NavigationInterfaceEvent ev -> case ev of + NavigationInterface.Log message -> H.tell _log unit (AppLog.Log message) + NavigationInterface.Routing page -> handleAction $ Routing page + NavigationInterface.Disconnection -> handleAction $ Disconnection + AuthenticationInterfaceEvent ev -> case ev of AI.MessageToSend message -> H.tell _ws_auth unit (WS.ToSend message) AI.AuthenticateToAuthd v -> handleAction $ AuthenticateToAuthd (Right v) @@ -457,6 +450,7 @@ handleAction = case _ of handleAction $ Log $ ErrorLog "Email required!" (AuthD.GotErrorInvalidCredentials _) -> do handleAction $ Log $ ErrorLog "Invalid credentials!" + handleAction $ ToggleAuthenticated Nothing (AuthD.GotErrorRegistrationsClosed _) -> do handleAction $ Log $ ErrorLog "Registration closed! Try another time or contact an administrator." (AuthD.GotErrorInvalidLoginFormat _) -> do @@ -479,6 +473,7 @@ handleAction = case _ of (AuthD.GotToken msg) -> do handleAction $ Log $ SuccessLog $ "Authenticated to authd!" H.modify_ _ { token = Just msg.token } + handleAction $ ToggleAuthenticated (Just msg.token) sessionstorage <- H.liftEffect $ Window.sessionStorage =<< HTML.window _ <- H.liftEffect $ Storage.setItem "user-authd-token" msg.token sessionstorage @@ -561,6 +556,8 @@ handleAction = case _ of (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." m@(DNSManager.MkUnacceptableDomain _) -> do diff --git a/src/App/Nav.purs b/src/App/Nav.purs index da0d725..910bd10 100644 --- a/src/App/Nav.purs +++ b/src/App/Nav.purs @@ -32,13 +32,6 @@ netlibre_navbar authenticated admin false, _ -> [ link_home ] _, false -> [ link_home, link_domains ] _, _ -> [ link_home, link_domains, link_authd_admin ] - --, dropdown "List of something" - -- [ dropdown_element "something 1" - -- , dropdown_element "something 2" - -- , dropdown_element "something 3" - -- , dropdown_separator - -- , dropdown_element "something 4" - -- ] ] , navbar_end [ navbar_item @@ -58,7 +51,15 @@ netlibre_navbar authenticated admin logo = HH.a [HP.classes C.navbar_item, HP.href "/"] [HH.img [HP.src "/logo.jpeg", HP.width 112, HP.height 28]] burger_menu = HH.a [HP.classes C.navbar_burger, ARIA.label "menu", ARIA.expanded "false", Bulma.data_target "navbarExample" ] - [ HH.span [ARIA.hidden "true"] [] + [ HH.span [ARIA.hidden "true"] [ + dropdown "List of something" + [ dropdown_element "something 1" + , dropdown_element "something 2" + , dropdown_element "something 3" + , dropdown_separator + , dropdown_element "something 4" + ] + ] , HH.span [ARIA.hidden "true"] [] , HH.span [ARIA.hidden "true"] [] ] @@ -70,12 +71,14 @@ netlibre_navbar authenticated admin link_domains = nav_button C.is_info "Domains" actionDomainList link_authd_admin = nav_button C.is_info "Admin" actionAdmin nav_button_disconnection = nav_button C.is_danger "Disconnection" actionDisconnection - --dropdown title dropdown_elements - -- = HH.div [HP.classes (C.navbar_item <> C.has_dropdown <> C.is_hoverable)] - -- [ dropdown_title title, HH.div [HP.classes C.navbar_dropdown] dropdown_elements ] - --dropdown_title str = HH.a [HP.classes C.navbar_link] [HH.text str] - --dropdown_element str = HH.a [HP.classes C.navbar_item] [HH.text str] - --dropdown_separator = HH.hr [HP.classes C.navbar_divider] + + dropdown title dropdown_elements + = HH.div [HP.classes (C.navbar_item <> C.has_dropdown <> C.is_hoverable)] + [ dropdown_title title, HH.div [HP.classes C.navbar_dropdown] dropdown_elements ] + dropdown_title str = HH.a [HP.classes C.navbar_link] [HH.text str] + dropdown_element str = HH.a [HP.classes C.navbar_item] [HH.text str] + dropdown_separator = HH.hr [HP.classes C.navbar_divider] + nav_button_code = btn_link [] "https://git.baguette.netlib.re/Baguette/dnsmanager" "Code" nav_button_strong str action = btn C.is_primary action (HH.strong [] [ HH.text str ]) nav_button classes str action = btn classes action (HH.text str) diff --git a/src/App/NavigationInterface.purs b/src/App/NavigationInterface.purs new file mode 100644 index 0000000..901d4dd --- /dev/null +++ b/src/App/NavigationInterface.purs @@ -0,0 +1,104 @@ +-- | `App.NavigationInterface` is the navbar module. +-- | +-- | This module is required since some javascript is needed to toggle display of hidden resources. +-- | On mobile, a burger menu is displayed and hides the navigation buttons. +-- | On desktop, there is no need for this, all the navigation buttons are displayed by default. +module App.NavigationInterface where + +import Prelude (Unit, not, ($), discard, pure) + +import App.Nav as Nav + +-- import Data.Array as A +import Data.Maybe (Maybe(..)) +-- import Data.Either (Either(..)) +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 Bulma as Bulma + +import App.Pages (Page(..)) +import App.LogMessage (LogMessage) + +data Output + = Log LogMessage + -- | Once someone clicks on a routing button, `App.Container` needs to know. + | Routing Page + -- | Once someone clicks on a the Disconnection button, `App.Container` needs to know. + | Disconnection + +-- | The component needs to know when the user is logged or not. +data Query a = ToggleLogged Boolean a + +type Slot = H.Slot Query Output + +type Input = Unit + +data Action + -- | `ToggleMenu`: display or hide the content of the burger menu. + = ToggleMenu + -- | The navigation interface must be informed when the client wants to change page. + -- | The request will be propagated to the parent (`App.Container`). + -- | (`Navigate` is `App.Container.Routing`) + | Navigate Page + -- | The navigation interface must be informed when the client wants to disconnect. + -- | The request will be propagated to the parent (`App.Container`). + -- | (`UnLog` is `App.Container.Disconnection`) + | UnLog + +-- | State is composed of: +-- | - `logged`, a boolean to toggle the display of some parts of the menu. +-- | - `active`, a boolean to toggle the display of the menu. +type State = { logged :: Boolean, active :: 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 _ = { logged: false, active: false } + +render :: forall m. State -> H.ComponentHTML Action () m +render { logged, active } + = Bulma.section_small + [ case active of + true -> Bulma.btn "ACTIVE" ToggleMenu + false -> Bulma.alert_btn "NOT ACTIVE" ToggleMenu + , render_nav + ] + where + + -- TODO: this is needed to show the authd admin button + admin = true + + render_nav :: forall childslots monad. H.ComponentHTML Action childslots monad + render_nav = Nav.netlibre_navbar logged admin + (Navigate Home) + (Navigate DomainList) + (Navigate Administration) + (Navigate Authentication) + (Navigate Registration) + (Navigate MailValidation) + UnLog + +handleAction :: forall m. MonadAff m => Action -> H.HalogenM State Action () Output m Unit +handleAction = case _ of + ToggleMenu -> H.modify_ \state -> state { active = not state.active } + -- | Page change. + Navigate page -> H.raise $ Routing page + UnLog -> H.raise $ Disconnection + +handleQuery :: forall a m. MonadAff m => Query a -> H.HalogenM State Action () Output m (Maybe a) +handleQuery = case _ of + ToggleLogged islogged a -> do + H.modify_ _ { logged = islogged } + pure (Just a) diff --git a/src/App/Pages.purs b/src/App/Pages.purs new file mode 100644 index 0000000..cf1aea4 --- /dev/null +++ b/src/App/Pages.purs @@ -0,0 +1,12 @@ +module App.Pages where +-- | This list will grow in a near future. +-- | +-- | TODO: +data Page + = Home -- | `Home`: presentation of the project. + | Authentication -- | `Authentication`: authentication page. + | Registration -- | `Registration`: to register new people. + | 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. + | Administration -- | `Administration`: administration page (for both `authd` and `dnsmanagerd`).