From 47a2eff48421a841579b24598a30a21269f4c08e Mon Sep 17 00:00:00 2001 From: James Brechtel Date: Tue, 4 Aug 2026 09:49:16 -0400 Subject: [PATCH] feat: accept household invites via shareable /invite/ URL --- app/Main.hs | 13 ++++++++++++- src/Sis/Database.hs | 10 ++++------ src/Sis/Page/Household.hs | 3 ++- src/Sis/Route.hs | 21 ++++++++++++++++++++- src/Sis/Types.hs | 2 +- 5 files changed, 39 insertions(+), 10 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index 6585710..1d6a186 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,6 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -Wno-unused-imports -Wno-missing-export-lists -Wno-name-shadowing #-} @@ -20,6 +21,7 @@ import System.Environment (getArgs, lookupEnv) import System.FilePath (takeDirectory) import System.IO.Error (isDoesNotExistError) +import Sis (UserId (..)) import Sis.Database import Sis.Page.Activity import Sis.Page.Chores @@ -28,7 +30,7 @@ import Sis.Page.Household import Sis.Page.Login import Sis.Page.Signup import Sis.Route -import Sis.View.Layout (documentHead) +import Sis.View.Layout (UserSession (..), documentHead) import Web.Hyperbole import Web.Hyperbole.Application import Web.Hyperbole.Effect.Response @@ -108,6 +110,15 @@ router RDashboard = runPage Sis.Page.Dashboard.page router RChores = runPage Sis.Page.Chores.page router RHousehold = runPage Sis.Page.Household.page router RActivity = runPage Sis.Page.Activity.page +router (RInvite code) = do + mSession <- lookupSession @UserSession + case mSession of + Nothing -> redirect (routeUri RLogin) + Just us -> do + mHousehold <- acceptInvite (UserId (usUserId us)) (unInviteCode code) + case mHousehold of + Just _ -> redirect (routeUri RDashboard) + Nothing -> redirect (routeUri RHousehold) router RSeed = do seed redirect (routeUri RDashboard) diff --git a/src/Sis/Database.hs b/src/Sis/Database.hs index 3b5de63..b593590 100644 --- a/src/Sis/Database.hs +++ b/src/Sis/Database.hs @@ -80,7 +80,7 @@ data DB :: Effect where CreateInvite :: Int -> Maybe Text -> DB m Invite GetInvites :: Int -> DB m [Invite] RevokeInvite :: Int -> DB m () - AcceptInvite :: UserId -> Text -> DB m Household + AcceptInvite :: UserId -> Text -> DB m (Maybe Household) Seed :: DB m () type instance DispatchOf DB = 'Dynamic @@ -324,10 +324,8 @@ runDB conn = interpret $ \_ -> \case \ FROM households h JOIN memberships m ON m.household_id = h.id AND m.role = 'owner' WHERE h.id = ?" (Only hid) :: IO [(Int, Text, Int, Int)] - case listToMaybe [Household (HouseholdId hId) hName (UserId ownerId) count | (hId, hName, ownerId, count) <- hResult] of - Just h -> pure h - Nothing -> error "Household not found after accept" - _ -> error "Invite not found" + pure $ listToMaybe [Household (HouseholdId hId) hName (UserId ownerId) count | (hId, hName, ownerId, count) <- hResult] + _ -> pure Nothing Seed -> liftIO $ do let demoPassword = "password123" pwHash <- hashPasswordIO demoPassword @@ -524,7 +522,7 @@ getInvites = send . GetInvites revokeInvite :: (DB :> es) => Int -> Eff es () revokeInvite = send . RevokeInvite -acceptInvite :: (DB :> es) => UserId -> Text -> Eff es Household +acceptInvite :: (DB :> es) => UserId -> Text -> Eff es (Maybe Household) acceptInvite u = send . AcceptInvite u seed :: (DB :> es) => Eff es () diff --git a/src/Sis/Page/Household.hs b/src/Sis/Page/Household.hs index b32b2df..976ee2b 100644 --- a/src/Sis/Page/Household.hs +++ b/src/Sis/Page/Household.hs @@ -121,7 +121,8 @@ memberRow m = do inviteRow :: Invite -> View HouseholdPage () inviteRow i = do el @ att "class" nbListItemClass @ att "style" "display:flex;justify-content:space-between;padding:0.5rem" $ do - el @ att "style" "font-size:0.85rem" $ text ("/invite/" <> inviteCode i) + route (RInvite (InviteCode (inviteCode i))) @ att "class" nbButtonDefaultClass @ att "style" "font-size:0.85rem;text-decoration:none" $ + text (inviteCode i) button (RevokeInviteAction (inviteId i)) @ att "class" nbButtonDefaultClass @ att "style" "font-size:0.8rem;background:var(--nb-red)" $ text "Revoke" diff --git a/src/Sis/Route.hs b/src/Sis/Route.hs index 2f44467..2296080 100644 --- a/src/Sis/Route.hs +++ b/src/Sis/Route.hs @@ -1,10 +1,28 @@ {-# LANGUAGE DeriveGeneric #-} -module Sis.Route (AppRoute (..)) where +module Sis.Route (AppRoute (..), InviteCode (..)) where +import Data.Text (Text) import GHC.Generics (Generic) import Web.Hyperbole.Route +---------------------------------------------------------------------- +-- Invite Code +---------------------------------------------------------------------- + +newtype InviteCode = InviteCode {unInviteCode :: Text} + deriving stock (Show, Eq) + +instance Route InviteCode where + matchRoute (Path [t]) = Just (InviteCode t) + matchRoute _ = Nothing + routePath (InviteCode c) = Path [c] + baseRoute = Nothing + +---------------------------------------------------------------------- +-- App Routes +---------------------------------------------------------------------- + data AppRoute = Home | RLogin @@ -13,6 +31,7 @@ data AppRoute | RChores | RHousehold | RActivity + | RInvite InviteCode | RSeed deriving stock (Eq, Generic, Show) diff --git a/src/Sis/Types.hs b/src/Sis/Types.hs index 1de8483..3189551 100644 --- a/src/Sis/Types.hs +++ b/src/Sis/Types.hs @@ -78,7 +78,7 @@ newtype ChoreId = ChoreId {unChoreId :: Int} newtype OccurrenceId = OccurrenceId {unOccurrenceId :: Int} deriving newtype (Show, Eq, Read, ToJSON, FromJSON) -newtype ActivityId = ActivityId {unActivityId :: Int} +newtype ActivityId = ActivityId Int deriving newtype (Show, Eq, Read, ToJSON, FromJSON) newtype InviteId = InviteId {unInviteId :: Int}