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:
@@ -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
|
||||||
|
|||||||
@@ -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'
|
||||||
|
|||||||
@@ -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
|
||||||
|
|||||||
@@ -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
|
||||||
|
|||||||
@@ -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)
|
||||||
|
|||||||
@@ -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
@@ -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
|
||||||
|
|||||||
Reference in New Issue
Block a user