feat: accept household invites via shareable /invite/<code> URL

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)

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 ()

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"
 

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)
 

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}