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

@@ -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 $
+    let app = liveAppWith
-        Static.staticPolicy (Static.addBase "frontend/static") $
-            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

package.yaml

@@ -70,6 +70,8 @@ executables:
       - effectful
       - hyperbole
       - sis-server
+      - wai-app-static
+      - wai-extra
 
 tests:
   sis-server-test:

sis-server.cabal

@@ -101,6 +101,8 @@ executable sis-server
     , text
     , time
     , wai
+    , wai-app-static
+    , wai-extra
     , warp
   default-language: Haskell2010
 

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

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'

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 "Overdue" (T.pack (show (dsOverdue stats))) colorRed
-            statTile "Due Today" (show (dsDueToday stats)) colorYellow
+            statTile "Due Today" (T.pack (show (dsDueToday stats))) colorYellow
-            statTile "Done This Week" (show (dsDoneThisWeek stats)) colorGreen
+            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

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

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...")
+            pure $ hyper LoginPage $ el "Redirecting..."
-        Nothing -> pure (loginView Nothing)
+        Nothing -> pure $ hyper LoginPage $ loginView Nothing

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...")
+            pure $ hyper SignupPage $ el "Redirecting..."
-        Nothing -> pure (signupView Nothing)
+        Nothing -> pure $ hyper SignupPage $ signupView Nothing