jbrechtel/sis
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

feat: Hyperbole port compiles and builds successfully

Browse Source 
- 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
This commit is contained in:
James Brechtel
2026-07-16 06:50:20 -04:00
parent c45ae41645
commit a717d619d3
9 changed files with 62 additions and 49 deletions
Download Patch File Download Diff File Expand all files Collapse all files
app/Main.hs
+7 -5
View File
@@ -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
package.yaml
+2
View File
@@ -70,6 +70,8 @@ executables:
- effectful
- hyperbole
- sis-server
- wai-app-static
- wai-extra
tests:
sis-server-test:
sis-server.cabal
+2
View File
@@ -101,6 +101,8 @@ executable sis-server
, text
, time
, wai
, wai-app-static
, wai-extra
, warp
default-language: Haskell2010
src/Sis/Page/Activity.hs
+10 -8
View File
@@ -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
+10 -8
View File
@@ -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
+14 -12
View File
@@ -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
src/Sis/Page/Household.hs
+8 -7
View File
@@ -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
+5 -5
View File
@@ -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
src/Sis/Page/Signup.hs
+4 -4
View File
@@ -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