karchnu/halogen-websocket-ipc-playzone
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Navigation bar now has a dedicated component.

Browse Source
This commit is contained in:
Philippe Pittoli 2024-02-22 05:42:25 +01:00
parent 88b1221569
commit 6c4ed85335
4 changed files with 159 additions and 43 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

55
src/App/Container.purs
View File

@ -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

31
src/App/Nav.purs
View File

@ -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)

104
src/App/NavigationInterface.purs Normal file
View File

@ -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)

12
src/App/Pages.purs Normal file
View File

@ -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`).