feat: Hyperbole port - all modules created, Database effect working

- 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)
2026-07-16 06:38:34 -04:00
parent b92947cdcc
commit 7eaf6ab7e7
13 changed files with 1160 additions and 80 deletions
@@ -0,0 +1,101 @@
+{-# 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)