feat: rebuild navbar with NB structure — Sis brand, nav links with nb-navbar-link class inside nb-navbar-item wrappers, user initials avatar

- UserSession now carries usDisplayName for extracting initials (current: JB)
- Nav items: Today (was Dashboard), Chores, Activity, Household
- Removed Logout link; added black user avatar circle with initials
- routeLink generates proper <li class='nb-navbar-item'><a class='nb-navbar-link'> structure
- All pages wrapped with pageLayout to render shared navbar shell
- Login/Signup save display name into session on authentication
This commit is contained in:
2026-07-16 09:05:56 -04:00
parent bcdda0754b
commit 02044642a7
7 changed files with 37 additions and 19 deletions
+2 -2
View File
@@ -101,7 +101,7 @@ page = do
Just us -> do Just us -> do
hhs <- getUserHouseholds (UserId (usUserId us)) hhs <- getUserHouseholds (UserId (usUserId us))
case hhs of case hhs of
[] -> pure $ hyper ActivityPage $ el "No households" [] -> pure $ hyper ActivityPage $ pageLayout us $ el "No households"
(h : _) -> do (h : _) -> do
log <- getActivityLog (unHouseholdId (householdId h)) 1 20 log <- getActivityLog (unHouseholdId (householdId h)) 1 20
pure $ hyper ActivityPage $ activityView log pure $ hyper ActivityPage $ pageLayout us $ activityView log
+2 -2
View File
@@ -98,7 +98,7 @@ page = do
Just us -> do Just us -> do
hhs <- getUserHouseholds (UserId (usUserId us)) hhs <- getUserHouseholds (UserId (usUserId us))
case hhs of case hhs of
[] -> pure $ hyper ChoresPage $ el "No households" [] -> pure $ hyper ChoresPage $ pageLayout us $ el "No households"
(h : _) -> do (h : _) -> do
chores' <- getChores (unHouseholdId (householdId h)) chores' <- getChores (unHouseholdId (householdId h))
pure $ hyper ChoresPage $ choresView chores' pure $ hyper ChoresPage $ pageLayout us $ choresView chores'
+2 -2
View File
@@ -115,7 +115,7 @@ page = do
today <- liftIO (utctDay <$> getCurrentTime) today <- liftIO (utctDay <$> getCurrentTime)
hhs <- getUserHouseholds (UserId (usUserId us)) hhs <- getUserHouseholds (UserId (usUserId us))
case hhs of case hhs of
[] -> pure $ hyper DashboardPage $ el "No households" [] -> pure $ hyper DashboardPage $ pageLayout us $ el "No households"
(h : _) -> do (h : _) -> do
dash <- getDashboard (unHouseholdId (householdId h)) today dash <- getDashboard (unHouseholdId (householdId h)) today
pure $ hyper DashboardPage $ dashboardView dash pure $ hyper DashboardPage $ pageLayout us $ dashboardView dash
+2 -2
View File
@@ -123,9 +123,9 @@ page = do
Just us -> do Just us -> do
hhs <- getUserHouseholds (UserId (usUserId us)) hhs <- getUserHouseholds (UserId (usUserId us))
case hhs of case hhs of
[] -> pure $ hyper HouseholdPage noHouseholdView [] -> pure $ hyper HouseholdPage $ pageLayout us noHouseholdView
(h : _) -> do (h : _) -> do
let hid = unHouseholdId (householdId h) let hid = unHouseholdId (householdId h)
mems <- getMembers hid mems <- getMembers hid
invs <- getInvites hid invs <- getInvites hid
pure $ hyper HouseholdPage $ householdView h mems invs pure $ hyper HouseholdPage $ pageLayout us $ householdView h mems invs
+1 -1
View File
@@ -40,7 +40,7 @@ instance (DB :> es, IOE :> es) => HyperView LoginPage es where
case mUser of case mUser of
Just u Just u
| verifyPassword (lfPassword formData') (userPasswordHash u) -> do | verifyPassword (lfPassword formData') (userPasswordHash u) -> do
saveSession (UserSession (unUserId (userId u))) saveSession (UserSession (unUserId (userId u)) (userDisplayName u))
pure loginSuccessView pure loginSuccessView
_ -> pure (loginView (Just "Invalid email or password")) _ -> pure (loginView (Just "Invalid email or password"))
update Noop = pure (loginView Nothing) update Noop = pure (loginView Nothing)
+1 -1
View File
@@ -48,7 +48,7 @@ instance (DB :> es, IOE :> es) => HyperView SignupPage es where
Nothing -> do Nothing -> do
pwHash <- liftIO (hashPassword (sfPassword form)) pwHash <- liftIO (hashPassword (sfPassword form))
uid <- createUser (sfDisplayName form) (sfEmail form) pwHash uid <- createUser (sfDisplayName form) (sfEmail form) pwHash
saveSession (UserSession (unUserId uid)) saveSession (UserSession (unUserId uid) (sfDisplayName form))
pure signupSuccessView pure signupSuccessView
signupSuccessView :: View SignupPage () signupSuccessView :: View SignupPage ()
+27 -9
View File
@@ -6,25 +6,29 @@
module Sis.View.Layout ( module Sis.View.Layout (
documentHead, documentHead,
navbar, navbar,
pageLayout,
UserSession (..), UserSession (..),
) where ) where
import Data.Aeson import Data.Aeson
import Data.Default import Data.Default
import Data.Text (Text) import Data.Text (Text)
import Data.Text qualified as T
import GHC.Generics (Generic) import GHC.Generics (Generic)
import Sis.Route import Sis.Route
import Sis.Style (nbButtonDefaultClass, nbHeadingClass, nbNavbarClass, nbNavbarLinkClass) import Sis.Style (nbButtonDefaultClass, nbHeadingClass, nbNavbarClass, nbNavbarLinkClass)
import Web.Hyperbole import Web.Hyperbole
import Web.Hyperbole.Data.URI (uriToText)
import Web.Hyperbole.Effect.Session import Web.Hyperbole.Effect.Session
---------------------------------------------------------------------- ----------------------------------------------------------------------
-- Session -- Session
---------------------------------------------------------------------- ----------------------------------------------------------------------
newtype UserSession = UserSession data UserSession = UserSession
{ usUserId :: Int { usUserId :: Int
, usDisplayName :: Text
} }
deriving stock (Show, Eq, Generic) deriving stock (Show, Eq, Generic)
deriving anyclass (FromJSON, ToJSON) deriving anyclass (FromJSON, ToJSON)
@@ -34,7 +38,7 @@ instance Session UserSession where
cookieSecure = False cookieSecure = False
instance Default UserSession where instance Default UserSession where
def = UserSession 0 def = UserSession 0 ""
---------------------------------------------------------------------- ----------------------------------------------------------------------
-- Document Head -- Document Head
@@ -58,17 +62,31 @@ documentHead = do
-- Navbar -- Navbar
---------------------------------------------------------------------- ----------------------------------------------------------------------
navbar :: View ctx () navbar :: UserSession -> View ctx ()
navbar = do navbar us = do
el @ att "class" nbNavbarClass $ do el @ att "class" nbNavbarClass $ do
el @ att "class" "nb-navbar-brand" @ att "style" "font-weight:700" $ text "Sis" tag "a" @ att "class" "nb-navbar-brand" . att "href" (uriToText (routeUri RDashboard)) $ text "Sis"
el @ att "class" "nb-navbar-nav" $ do el @ att "class" "nb-navbar-nav" $ do
routeLink RDashboard "Dashboard" routeLink RDashboard "Today"
routeLink RChores "Chores" routeLink RChores "Chores"
routeLink RHousehold "Household"
routeLink RActivity "Activity" routeLink RActivity "Activity"
routeLink RLogin "Logout" routeLink RHousehold "Household"
el @ att "class" "nb-navbar-avatar" @ att "style" "width:2.5rem;height:2.5rem;border-radius:50%;background:#000;color:#fff;display:flex;align-items:center;justify-content:center;font-family:'Lexend Mega','Public Sans',sans-serif;font-weight:900;font-size:0.85rem;flex-shrink:0" $
text (initials (usDisplayName us))
routeLink :: (Route r) => r -> Text -> View ctx () routeLink :: (Route r) => r -> Text -> View ctx ()
routeLink rt lbl = do routeLink rt lbl = do
el @ att "class" nbNavbarLinkClass $ route rt $ text lbl tag "li" @ att "class" "nb-navbar-item" $ do
tag "a" @ att "class" nbNavbarLinkClass . att "href" (uriToText (routeUri rt)) $ text lbl
-- | Extract up to 2 initials from a display name
initials :: Text -> Text
initials displayName =
let ws = map (T.take 1) (T.words displayName)
in T.toUpper (T.take 2 (T.concat ws))
-- | Wrap content in a shared page shell (navbar + container)
pageLayout :: UserSession -> View ctx () -> View ctx ()
pageLayout us body = do
navbar us
body