jbrechtel
c45ae41645
- Fix tag calls to use \$ none for self-closing tags - Add IOE constraint to HyperView instances - Add warning suppressions where needed - Fix Form data type imports - Remove duplicate getUserHouseholds helpers - Remaining issues: String/Text mismatches in text calls, a few view DSL type errors in Dashboard/Chores
113 lines
5.1 KiB
Haskell
113 lines
5.1 KiB
Haskell
{-# LANGUAGE FlexibleContexts, DeriveAnyClass, DeriveGeneric, MultiParamTypeClasses, FlexibleInstances, UndecidableInstances, TypeApplications, TypeOperators, OverloadedStrings #-}
|
|
|
|
module Sis.Page.Dashboard (page) where
|
|
|
|
import Data.Maybe (fromMaybe)
|
|
import Data.Text (Text)
|
|
import Data.Time (getCurrentTime, utctDay)
|
|
import Effectful
|
|
|
|
import Sis.Database
|
|
import Sis.Route
|
|
import Sis.Style
|
|
import Sis.Types
|
|
import Sis.View.Layout
|
|
import Web.Hyperbole
|
|
import Web.Hyperbole.Effect.Session
|
|
import Web.Hyperbole.Page
|
|
|
|
data DashboardPage = DashboardPage
|
|
deriving stock (Generic)
|
|
deriving anyclass (ViewId)
|
|
|
|
instance (DB :> es, IOE :> es) => HyperView DashboardPage es where
|
|
data Action DashboardPage
|
|
= RefreshDashboard
|
|
| CheckOff OccurrenceId
|
|
deriving stock (Generic)
|
|
deriving anyclass (ViewAction)
|
|
|
|
update RefreshDashboard = do
|
|
mUser <- lookupSession @UserSession
|
|
case mUser of
|
|
Nothing -> pure (el "Not authenticated")
|
|
Just us -> do
|
|
today <- liftIO (utctDay <$> getCurrentTime)
|
|
hhs <- getUserHouseholds (UserId (usUserId us))
|
|
case hhs of
|
|
[] -> pure (el "No households found")
|
|
(h : _) -> do
|
|
dash <- getDashboard (unHouseholdId (householdId h)) today
|
|
pure (dashboardView dash)
|
|
update (CheckOff _oid) = do
|
|
-- TODO: wire up to activity form
|
|
update RefreshDashboard
|
|
|
|
dashboardView :: Dashboard -> View DashboardPage ()
|
|
dashboardView dash = do
|
|
el @ att "class" nbContainerClass @ att "style" "max-width:960px;margin:0 auto" $ do
|
|
el @ att "class" nbFontHeading1Class $ text "Dashboard"
|
|
el @ att "style" "display:flex;gap:1rem;margin-bottom:1.5rem" $ do
|
|
let stats = dashStats dash
|
|
statTile "Overdue" (show (dsOverdue stats)) colorRed
|
|
statTile "Due Today" (show (dsDueToday stats)) colorYellow
|
|
statTile "Done This Week" (show (dsDoneThisWeek stats)) colorGreen
|
|
el @ att "class" nbFontHeading2Class $ text "Overdue & Due Today"
|
|
if null (dashDueItems dash)
|
|
then el @ att "style" "opacity:0.5" $ text "Nothing due! Great job."
|
|
else el @ att "class" nbBoxClass $ do
|
|
mapM_ dueItemRow (dashDueItems dash)
|
|
el @ att "class" nbFontHeading2Class $ text "Completed Today"
|
|
if null (dashCompletedItems dash)
|
|
then el @ att "style" "opacity:0.5" $ text "No activity recorded today."
|
|
else el @ att "class" nbBoxClass $ mapM_ completedItemRow (dashCompletedItems dash)
|
|
route RouteActivity $ text "View Full Activity Log"
|
|
|
|
statTile :: Text -> Text -> Text -> View ctx ()
|
|
statTile label count color = do
|
|
el @ att "class" nbBoxClass @ att "style" ("flex:1;text-align:center;padding:1rem;border-color:" <> color) $ do
|
|
el @ att "class" nbFontHeading1Class $ text count
|
|
text label
|
|
|
|
dueItemRow :: DueItem -> View ctx ()
|
|
dueItemRow di = do
|
|
el @ att "class" nbListItemClass @ att "style" "display:flex;justify-content:space-between;align-items:center;padding:0.5rem" $ do
|
|
el @ att "style" "display:flex;gap:0.5rem;align-items:center" $ do
|
|
let badgeColor = if diIsOverdue di then colorRed else colorYellow
|
|
badgeText = if diIsOverdue di then "OVERDUE" else "DUE"
|
|
el @ att "class" nbBadgeClass @ att "style" ("background:" <> badgeColor <> ";color:#000") $ text badgeText
|
|
text (diChoreName di)
|
|
case diAssigneeName di of
|
|
Just name -> el @ att "style" "opacity:0.5" $ text ("(" <> name <> ")")
|
|
Nothing -> none
|
|
button (CheckOff (occurrenceId (diOccurrence di))) @ att "class" nbButtonClass @ att "style" "font-size:0.85rem" $ text "Check Off"
|
|
|
|
completedItemRow :: CompletedItem -> View ctx ()
|
|
completedItemRow ci = do
|
|
el @ att "class" nbListItemClass @ att "style" "padding:0.5rem" $ do
|
|
let act = ciActivity ci
|
|
statusText = case activityStatus act of
|
|
ActivityCompleted -> "COMPLETED"
|
|
ActivitySkipped -> "SKIPPED"
|
|
el @ att "class" nbBadgeClass @ att "style" ("margin-right:0.5rem;background:" <> colorGreen <> ";color:#000") $ text statusText
|
|
text (ciUserName ci <> " " <> show (activityStatus act) <> " " <> ciChoreName ci)
|
|
case activityNote act of
|
|
Just note -> el @ att "style" "opacity:0.5;font-style:italic;margin-left:0.5rem" $ text ("— \"" <> note <> "\"")
|
|
Nothing -> none
|
|
|
|
page :: (Hyperbole :> es, DB :> es) => Eff es (View DashboardPage ())
|
|
page = do
|
|
mSession <- lookupSession @UserSession
|
|
case mSession of
|
|
Nothing -> do
|
|
redirect (routeUri RouteLogin)
|
|
pure (el "Redirecting...")
|
|
Just us -> do
|
|
today <- liftIO (utctDay <$> getCurrentTime)
|
|
hhs <- getUserHouseholds (UserId (usUserId us))
|
|
case hhs of
|
|
[] -> pure (el "No households — create one first")
|
|
(h : _) -> do
|
|
dash <- getDashboard (unHouseholdId (householdId h)) today
|
|
pure (dashboardView dash)
|