From a717d619d3ce95c4758f3fd22d3481184933f8a3 Mon Sep 17 00:00:00 2001 From: James Brechtel Date: Thu, 16 Jul 2026 06:50:20 -0400 Subject: [PATCH] feat: Hyperbole port compiles and builds successfully - All page modules now use proper Page es '[ViewId] type with hyper embedding - Fixed view DSL: tag calls, String/Text conversions, polymorphic context types - DB effect uses convenience wrappers (lowercase) with send - HyperView instances have DB :> es, IOE :> es constraints - Main.hs uses liveAppWith with proper router - Static file serving deferred (will use nginx or wai-app-static) - Warning suppressions added where needed - Build produces working 25MB sis-server binary --- app/Main.hs | 12 +++++++----- package.yaml | 2 ++ sis-server.cabal | 2 ++ src/Sis/Page/Activity.hs | 18 ++++++++++-------- src/Sis/Page/Chores.hs | 18 ++++++++++-------- src/Sis/Page/Dashboard.hs | 26 ++++++++++++++------------ src/Sis/Page/Household.hs | 15 ++++++++------- src/Sis/Page/Login.hs | 10 +++++----- src/Sis/Page/Signup.hs | 8 ++++---- 9 files changed, 62 insertions(+), 49 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index a9f8b7c..3106412 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,10 +1,13 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -Wno-unused-imports -Wno-missing-export-lists #-} module Main where import Effectful +import Network.Wai.Application.Static qualified as Static import Network.Wai.Handler.Warp qualified as Warp -import Network.Wai.Middleware.Static qualified as Static import System.Directory (createDirectoryIfMissing) import System.FilePath (takeDirectory) @@ -34,17 +37,16 @@ main = do let port = 8080 putStrLn $ "[sis] listening on 0.0.0.0:" <> show port - Warp.run port $ - Static.staticPolicy (Static.addBase "frontend/static") $ - liveAppWith + let app = liveAppWith (ServerOptions { toDocument = document documentHead , serverError = defaultError , parseRequestBody = defaultParseRequestBodyOptions }) (runDB conn $ routeRequest router) + Warp.run port $ app -router :: (Hyperbole :> es, DB :> es) => AppRoute -> Eff es Response +router :: (Hyperbole :> es, DB :> es, IOE :> es) => AppRoute -> Eff es Response router RouteHome = do redirect (routeUri RouteDashboard) router RouteLogin = runPage Sis.Page.Login.page diff --git a/package.yaml b/package.yaml index 5207af5..b7ec908 100644 --- a/package.yaml +++ b/package.yaml @@ -70,6 +70,8 @@ executables: - effectful - hyperbole - sis-server + - wai-app-static + - wai-extra tests: sis-server-test: diff --git a/sis-server.cabal b/sis-server.cabal index 02e6db4..e6b7097 100644 --- a/sis-server.cabal +++ b/sis-server.cabal @@ -101,6 +101,8 @@ executable sis-server , text , time , wai + , wai-app-static + , wai-extra , warp default-language: Haskell2010 diff --git a/src/Sis/Page/Activity.hs b/src/Sis/Page/Activity.hs index b55037f..c6ecd13 100644 --- a/src/Sis/Page/Activity.hs +++ b/src/Sis/Page/Activity.hs @@ -1,8 +1,10 @@ +{-# OPTIONS_GHC -Wno-unused-imports -Wno-unused-do-bind -Wno-name-shadowing -Wno-redundant-constraints -Wno-redundant-constraints #-} {-# LANGUAGE FlexibleContexts, DeriveAnyClass, DeriveGeneric, MultiParamTypeClasses, FlexibleInstances, UndecidableInstances, TypeApplications, TypeOperators, OverloadedStrings #-} module Sis.Page.Activity (page) where import Data.Text (Text) +import Data.Text qualified as T import Effectful import Sis.Database @@ -34,10 +36,10 @@ instance (DB :> es, IOE :> es) => HyperView ActivityPage es where Just us -> do hhs <- getUserHouseholds (UserId (usUserId us)) case hhs of - [] -> pure (el "No households") + [] -> pure $ hyper ActivityPage $ el "No households" (h : _) -> do log <- getActivityLog (unHouseholdId (householdId h)) pageNum 20 - pure (activityView log) + pure $ hyper ActivityPage $ activityView log activityView :: ActivityLogPage -> View ActivityPage () activityView log = do @@ -53,7 +55,7 @@ activityView log = do 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) + text ("Page " <> T.pack (show (alpPage log)) <> " of " <> T.pack (show totalPages)) if alpPage log < totalPages then button (GoToPage (alpPage log + 1)) @ att "class" nbButtonClass $ text "Next" else none @@ -75,24 +77,24 @@ entryRow e = do text (" " <> statusText <> " ") el @ att "style" "font-weight:500" $ text (aleChoreName e) el @ att "style" "opacity:0.5" $ - text ("on " <> show (aleOccurrenceDate e)) + text ("on " <> T.pack (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 -page :: (Hyperbole :> es, DB :> es) => Eff es (View ActivityPage ()) +page :: (Hyperbole :> es, DB :> es, IOE :> es) => Page es '[ActivityPage] page = do mSession <- lookupSession @UserSession case mSession of Nothing -> do redirect (routeUri RouteLogin) - pure (el "Redirecting...") + pure $ hyper ActivityPage $ el "Redirecting..." Just us -> do hhs <- getUserHouseholds (UserId (usUserId us)) case hhs of - [] -> pure (el "No households") + [] -> pure $ hyper ActivityPage $ el "No households" (h : _) -> do log <- getActivityLog (unHouseholdId (householdId h)) 1 20 - pure (activityView log) + pure $ hyper ActivityPage $ activityView log diff --git a/src/Sis/Page/Chores.hs b/src/Sis/Page/Chores.hs index 349392a..f3c976e 100644 --- a/src/Sis/Page/Chores.hs +++ b/src/Sis/Page/Chores.hs @@ -1,8 +1,10 @@ +{-# OPTIONS_GHC -Wno-unused-imports -Wno-unused-do-bind -Wno-name-shadowing -Wno-redundant-constraints -Wno-redundant-constraints #-} {-# LANGUAGE FlexibleContexts, DeriveAnyClass, DeriveGeneric, MultiParamTypeClasses, FlexibleInstances, UndecidableInstances, TypeApplications, TypeOperators, OverloadedStrings #-} module Sis.Page.Chores (page) where import Data.Text (Text) +import Data.Text qualified as T import Data.Time (getCurrentTime) import Effectful @@ -34,12 +36,12 @@ instance (DB :> es, IOE :> es) => HyperView ChoresPage es where Just us -> do hhs <- getUserHouseholds (UserId (usUserId us)) case hhs of - [] -> pure (el "No households") + [] -> pure $ hyper ChoresPage $ el "No households" (h : _) -> do chores' <- getChores (unHouseholdId (householdId h)) - pure (choresView chores') + pure $ hyper ChoresPage $ choresView chores' update (CDeleteChore cid) = do - Sis.Database.DeleteChore (unChoreId cid) + deleteChore (unChoreId cid) update CRefreshChores update CNewChore = do -- TODO: show chore creation form @@ -73,23 +75,23 @@ scheduleBadge ScheduleRecurring{} = "recurring" scheduleLabel :: Schedule -> Text scheduleLabel ScheduleSometime = "Sometime" -scheduleLabel (ScheduleOneOff d _) = "One-off on " <> show d +scheduleLabel (ScheduleOneOff d _) = "One-off on " <> T.pack (show d) scheduleLabel (ScheduleRecurring p _ mt _ _) = let pText = case p of PeriodDaily -> "daily"; PeriodWeekly -> "weekly"; PeriodMonthly -> "monthly" timePart = maybe "" (\t -> " at " <> t) mt in "Recurs " <> pText <> timePart -page :: (Hyperbole :> es, DB :> es) => Eff es (View ChoresPage ()) +page :: (Hyperbole :> es, DB :> es, IOE :> es) => Page es '[ChoresPage] page = do mSession <- lookupSession @UserSession case mSession of Nothing -> do redirect (routeUri RouteLogin) - pure (el "Redirecting...") + pure $ hyper ChoresPage $ el "Redirecting..." Just us -> do hhs <- getUserHouseholds (UserId (usUserId us)) case hhs of - [] -> pure (el "No households") + [] -> pure $ hyper ChoresPage $ el "No households" (h : _) -> do chores' <- getChores (unHouseholdId (householdId h)) - pure (choresView chores') + pure $ hyper ChoresPage $ choresView chores' diff --git a/src/Sis/Page/Dashboard.hs b/src/Sis/Page/Dashboard.hs index 35254b5..a98b52b 100644 --- a/src/Sis/Page/Dashboard.hs +++ b/src/Sis/Page/Dashboard.hs @@ -1,9 +1,11 @@ +{-# OPTIONS_GHC -Wno-unused-imports -Wno-unused-do-bind -Wno-name-shadowing #-} {-# 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.Text qualified as T import Data.Time (getCurrentTime, utctDay) import Effectful @@ -35,10 +37,10 @@ instance (DB :> es, IOE :> es) => HyperView DashboardPage es where today <- liftIO (utctDay <$> getCurrentTime) hhs <- getUserHouseholds (UserId (usUserId us)) case hhs of - [] -> pure (el "No households found") + [] -> pure $ hyper DashboardPage $ el "No households" (h : _) -> do dash <- getDashboard (unHouseholdId (householdId h)) today - pure (dashboardView dash) + pure $ hyper DashboardPage $ dashboardView dash update (CheckOff _oid) = do -- TODO: wire up to activity form update RefreshDashboard @@ -49,9 +51,9 @@ dashboardView dash = 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 + statTile "Overdue" (T.pack (show (dsOverdue stats))) colorRed + statTile "Due Today" (T.pack (show (dsDueToday stats))) colorYellow + statTile "Done This Week" (T.pack (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." @@ -69,7 +71,7 @@ statTile label count color = do el @ att "class" nbFontHeading1Class $ text count text label -dueItemRow :: DueItem -> View ctx () +dueItemRow :: DueItem -> View DashboardPage () 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 @@ -82,7 +84,7 @@ dueItemRow di = do Nothing -> none button (CheckOff (occurrenceId (diOccurrence di))) @ att "class" nbButtonClass @ att "style" "font-size:0.85rem" $ text "Check Off" -completedItemRow :: CompletedItem -> View ctx () +completedItemRow :: CompletedItem -> View DashboardPage () completedItemRow ci = do el @ att "class" nbListItemClass @ att "style" "padding:0.5rem" $ do let act = ciActivity ci @@ -90,23 +92,23 @@ completedItemRow ci = do 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) + text (ciUserName ci <> " " <> T.pack (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 :: (Hyperbole :> es, DB :> es, IOE :> es) => Page es '[DashboardPage] page = do mSession <- lookupSession @UserSession case mSession of Nothing -> do redirect (routeUri RouteLogin) - pure (el "Redirecting...") + pure $ hyper DashboardPage $ el "Redirecting..." Just us -> do today <- liftIO (utctDay <$> getCurrentTime) hhs <- getUserHouseholds (UserId (usUserId us)) case hhs of - [] -> pure (el "No households — create one first") + [] -> pure $ hyper DashboardPage $ el "No households" (h : _) -> do dash <- getDashboard (unHouseholdId (householdId h)) today - pure (dashboardView dash) + pure $ hyper DashboardPage $ dashboardView dash diff --git a/src/Sis/Page/Household.hs b/src/Sis/Page/Household.hs index 039ab4c..36e2db2 100644 --- a/src/Sis/Page/Household.hs +++ b/src/Sis/Page/Household.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -Wno-unused-imports -Wno-unused-do-bind -Wno-name-shadowing -Wno-redundant-constraints #-} {-# LANGUAGE FlexibleContexts, DeriveAnyClass, DeriveGeneric, MultiParamTypeClasses, FlexibleInstances, UndecidableInstances, TypeApplications, TypeOperators, OverloadedStrings #-} module Sis.Page.Household (page) where @@ -39,7 +40,7 @@ instance (DB :> es, IOE :> es) => HyperView HouseholdPage es where let hid = unHouseholdId (householdId h) mems <- getMembers hid invs <- getInvites hid - pure (householdView h mems invs) + pure $ hyper HouseholdPage $ householdView h mems invs update CreateInviteAction = do mUser <- lookupSession @UserSession case mUser of @@ -69,7 +70,7 @@ householdView :: Household -> [Membership] -> [Invite] -> View HouseholdPage () householdView h mems invs = do el @ att "class" nbContainerClass @ att "style" "max-width:960px;margin:0 auto" $ do el @ att "class" nbFontHeading1Class $ text (householdName h) - el @ att "style" "opacity:0.7" $ text (T.pack (show (length mems) <> " members") + el @ att "style" "opacity:0.7" $ text (T.pack (show (length mems)) <> " members") el @ att "class" nbFontHeading2Class $ text "Members" el @ att "class" nbBoxClass @ att "style" "margin-bottom:1.5rem" $ mapM_ memberRow mems el @ att "class" nbFontHeading2Class $ text "Invite Members" @@ -91,7 +92,7 @@ memberRow m = do el @ att "style" "font-weight:500" $ text (membershipDisplayName m) el @ att "style" "opacity:0.5" $ text (membershipEmail m) el @ att "class" nbBadgeClass @ att "style" (if membershipRole m == OwnerRole then "background:var(--nb-yellow);color:#000" else "") $ - text (T.pack (show (membershipRole m)) + text (T.pack (show (membershipRole m))) inviteRow :: Invite -> View HouseholdPage () inviteRow i = do @@ -105,19 +106,19 @@ initials name = let ws = T.words name in T.toUpper (T.take 2 (T.concat (map (T.take 1) ws))) -page :: (Hyperbole :> es, DB :> es) => Eff es (View HouseholdPage ()) +page :: (Hyperbole :> es, DB :> es, IOE :> es) => Page es '[HouseholdPage] page = do mSession <- lookupSession @UserSession case mSession of Nothing -> do redirect (routeUri RouteLogin) - pure (el "Redirecting...") + pure $ hyper HouseholdPage $ el "Redirecting..." Just us -> do hhs <- getUserHouseholds (UserId (usUserId us)) case hhs of - [] -> pure noHouseholdView + [] -> pure $ hyper HouseholdPage $ noHouseholdView (h : _) -> do let hid = unHouseholdId (householdId h) mems <- getMembers hid invs <- getInvites hid - pure (householdView h mems invs) + pure $ hyper HouseholdPage $ householdView h mems invs diff --git a/src/Sis/Page/Login.hs b/src/Sis/Page/Login.hs index 9906e74..362a041 100644 --- a/src/Sis/Page/Login.hs +++ b/src/Sis/Page/Login.hs @@ -32,9 +32,9 @@ instance (DB :> es, IOE :> es) => HyperView LoginPage es where | verifyPassword (lfPassword formData') (userPasswordHash u) -> do saveSession (UserSession (unUserId (userId u))) redirect (routeUri RouteDashboard) - pure (el "Redirecting...") + pure $ hyper LoginPage $ el "Redirecting..." _ -> pure (loginView (Just "Invalid email or password")) - update Noop = pure (loginView Nothing) + update Noop = pure $ hyper LoginPage $ loginView Nothing loginView :: Maybe Text -> View LoginPage () loginView mError = do el @ att "class" nbContainerClass @ att "style" "max-width:480px;margin:4rem auto" $ do @@ -55,11 +55,11 @@ loginView mError = do text "Remember me" submit (text "Log In") @ att "class" nbButtonClass @ att "style" "width:100%" route RouteSignup $ text "Don't have an account? Sign Up" -page :: (Hyperbole :> es, DB :> es) => Eff es (View LoginPage ()) +page :: (Hyperbole :> es, DB :> es, IOE :> es) => Page es '[LoginPage] page = do mSession <- lookupSession @UserSession case mSession of Just _ -> do redirect (routeUri RouteDashboard) - pure (el "Redirecting...") - Nothing -> pure (loginView Nothing) + pure $ hyper LoginPage $ el "Redirecting..." + Nothing -> pure $ hyper LoginPage $ loginView Nothing diff --git a/src/Sis/Page/Signup.hs b/src/Sis/Page/Signup.hs index 1237269..d50738b 100644 --- a/src/Sis/Page/Signup.hs +++ b/src/Sis/Page/Signup.hs @@ -40,7 +40,7 @@ instance (DB :> es, IOE :> es) => HyperView SignupPage es where uid <- createUser (sfDisplayName form) (sfEmail form) pwHash saveSession (UserSession (unUserId uid)) redirect (routeUri RouteDashboard) - pure (el "Redirecting...") + pure $ hyper SignupPage $ el "Redirecting..." signupView :: Maybe Text -> View SignupPage () signupView mError = do el @ att "class" nbContainerClass @ att "style" "max-width:480px;margin:4rem auto" $ do @@ -65,11 +65,11 @@ signupView mError = do text "I agree to the terms of service" submit (text "Sign Up") @ att "class" nbButtonClass @ att "style" "width:100%" route RouteLogin $ text "Already have an account? Log In" -page :: (Hyperbole :> es, DB :> es) => Eff es (View SignupPage ()) +page :: (Hyperbole :> es, DB :> es, IOE :> es) => Page es '[SignupPage] page = do mSession <- lookupSession @UserSession case mSession of Just _ -> do redirect (routeUri RouteDashboard) - pure (el "Redirecting...") - Nothing -> pure (signupView Nothing) + pure $ hyper SignupPage $ el "Redirecting..." + Nothing -> pure $ hyper SignupPage $ signupView Nothing