jbrechtel
7eaf6ab7e7
- Database.hs: effectful DB effect with all operations + convenience wrappers - Types.hs: stripped Aeson (kept ToJSON/FromJSON on IDs), added form types - Route.hs, Style.hs, View/Layout.hs: support modules - All Page modules: Login, Signup, Dashboard, Chores, Household, Activity - Main.hs: Hyperbole app entry point with router - Known issue: Hyperbole view DSL syntax needs cleanup in page modules (tag calls need $ none suffix, form elements need field wrappers)
102 lines
4.1 KiB
Haskell
102 lines
4.1 KiB
Haskell
{-# LANGUAGE FlexibleContexts, DeriveAnyClass, DeriveGeneric, MultiParamTypeClasses, FlexibleInstances, UndecidableInstances, TypeApplications, TypeOperators, OverloadedStrings #-}
|
|
|
|
module Sis.Page.Activity (page) where
|
|
|
|
import Data.Text (Text)
|
|
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 ActivityPage = ActivityPage
|
|
deriving stock (Generic)
|
|
deriving anyclass (ViewId)
|
|
|
|
instance (DB :> es) => HyperView ActivityPage es where
|
|
data Action ActivityPage
|
|
= RefreshActivity
|
|
| GoToPage Int
|
|
deriving stock (Generic)
|
|
deriving anyclass (ViewAction)
|
|
|
|
update RefreshActivity = do
|
|
update (GoToPage 1)
|
|
update (GoToPage pageNum) = do
|
|
mUser <- lookupSession @UserSession
|
|
case mUser of
|
|
Nothing -> pure (el "Not authenticated")
|
|
Just us -> do
|
|
hhs <- getUserHouseholds (UserId (usUserId us))
|
|
case hhs of
|
|
[] -> pure (el "No households")
|
|
(h : _) -> do
|
|
log <- getActivityLog (unHouseholdId (householdId h)) pageNum 20
|
|
pure (activityView log)
|
|
|
|
activityView :: ActivityLogPage -> View ActivityPage ()
|
|
activityView log = do
|
|
el @ att "class" nbContainerClass @ att "style" "max-width:960px;margin:0 auto" $ do
|
|
el @ att "class" nbFontHeading1Class $ text "Activity Log"
|
|
if null (alpEntries log)
|
|
then el @ att "style" "opacity:0.5" $ text "No activity recorded yet."
|
|
else el @ att "class" nbBoxClass $ mapM_ entryRow (alpEntries log)
|
|
if alpTotal log > alpPerPage log
|
|
then el @ att "style" "margin-top:1rem;display:flex;gap:0.5rem;justify-content:center" $ do
|
|
let totalPages = (alpTotal log + alpPerPage log - 1) `div` alpPerPage log
|
|
if alpPage log > 1
|
|
then button (GoToPage (alpPage log - 1)) @ att "class" nbButtonClass $ text "Previous"
|
|
else none
|
|
el @ att "style" "align-self:center" $
|
|
text ("Page " <> show (alpPage log) <> " of " <> show totalPages)
|
|
if alpPage log < totalPages
|
|
then button (GoToPage (alpPage log + 1)) @ att "class" nbButtonClass $ text "Next"
|
|
else none
|
|
else none
|
|
|
|
entryRow :: ActivityLogEntry -> View ActivityPage ()
|
|
entryRow e = do
|
|
let act = aleActivity e
|
|
statusText = case activityStatus act of
|
|
ActivityCompleted -> "COMPLETED"
|
|
ActivitySkipped -> "SKIPPED"
|
|
statusColor = case activityStatus act of
|
|
ActivityCompleted -> colorGreen
|
|
ActivitySkipped -> "var(--nb-orange)"
|
|
el @ att "class" nbListItemClass @ att "style" "padding:0.5rem" $ do
|
|
el @ att "class" nbBadgeClass @ att "style" ("margin-right:0.5rem;background:" <> statusColor <> ";color:#000") $
|
|
text statusText
|
|
el @ att "style" "font-weight:500" $ text (aleUserName e)
|
|
text (" " <> statusText <> " ")
|
|
el @ att "style" "font-weight:500" $ text (aleChoreName e)
|
|
el @ att "style" "opacity:0.5" $
|
|
text ("on " <> show (aleOccurrenceDate e))
|
|
case activityNote act of
|
|
Just note ->
|
|
el @ att "style" "opacity:0.5;font-style:italic;margin-left:0.5rem" $
|
|
text ("\"" <> note <> "\"")
|
|
Nothing -> none
|
|
|
|
getUserHouseholds :: (DB :> es) => UserId -> Eff es [Household]
|
|
getUserHouseholds = getUserHouseholds
|
|
|
|
page :: (Hyperbole :> es, DB :> es) => Eff es (View ActivityPage ())
|
|
page = do
|
|
mSession <- lookupSession @UserSession
|
|
case mSession of
|
|
Nothing -> do
|
|
redirect (routeUri RouteLogin)
|
|
pure (el "Redirecting...")
|
|
Just us -> do
|
|
hhs <- getUserHouseholds (UserId (usUserId us))
|
|
case hhs of
|
|
[] -> pure (el "No households")
|
|
(h : _) -> do
|
|
log <- getActivityLog (unHouseholdId (householdId h)) 1 20
|
|
pure (activityView log)
|