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

feat: household creation form — users without a household see a name input and Create Household button

Browse Source 
- Added userHouseholdId (Maybe HouseholdId) to User type
- Added household_id FK column to users table via migration (idempotent)
- CreateHousehold now also sets household_id on the creating user
- SetUserHousehold DB effect for explicit FK updates
- noHouseholdView replaced with a proper Hyperbole form using HouseholdFormData
- On submit, creates household + membership + sets user FK, then redirects to household view
This commit is contained in:
James Brechtel
2026-07-16 09:11:09 -04:00
parent 02044642a7
commit 5485bdfd0b
3 changed files with 43 additions and 13 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Sis/Database.hs
+21 -8
View File
@@ -2,6 +2,7 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
@@ -17,6 +18,7 @@ module Sis.Database (
findUserByEmail,
createUser,
getUser,
setUserHousehold,
getUserHouseholds,
getHousehold,
createHousehold,
@@ -35,6 +37,7 @@ module Sis.Database (
seed,
) where
import Control.Exception (IOException, catch)
import Control.Monad (when)
import Data.Maybe (fromMaybe, listToMaybe)
import Data.Text (Text)
@@ -64,6 +67,7 @@ data DB :: Effect where
FindUserByEmail :: Text -> DB m (Maybe User)
CreateUser :: Text -> Text -> Text -> DB m UserId
GetUser :: UserId -> DB m (Maybe User)
SetUserHousehold :: UserId -> HouseholdId -> DB m ()
GetUserHouseholds :: UserId -> DB m [Household]
GetHousehold :: UserId -> Int -> DB m (Maybe Household)
CreateHousehold :: UserId -> Text -> DB m Household
@@ -94,9 +98,9 @@ runDB conn = interpret $ \_ -> \case
result <-
SQL.query
conn
"SELECT id, display_name, email, password_hash FROM users WHERE email = ?"
"SELECT id, display_name, email, password_hash, household_id FROM users WHERE email = ?"
(Only email)
pure $ listToMaybe [User (UserId uid) dname em pwHash | (uid, dname, em, pwHash) <- result]
pure $ listToMaybe [User (UserId uid) dname em pwHash (HouseholdId <$> hId) | (uid, dname, em, pwHash, hId) <- result]
CreateUser dname email pwHash -> liftIO $ do
SQL.execute
conn
@@ -108,9 +112,11 @@ runDB conn = interpret $ \_ -> \case
result <-
SQL.query
conn
"SELECT id, display_name, email, password_hash FROM users WHERE id = ?"
"SELECT id, display_name, email, password_hash, household_id FROM users WHERE id = ?"
(Only uid)
pure $ listToMaybe [User (UserId uid') dname em pwHash | (uid', dname, em, pwHash) <- result]
pure $ listToMaybe [User (UserId uid') dname em pwHash (HouseholdId <$> hId) | (uid', dname, em, pwHash, hId) <- result]
SetUserHousehold (UserId uid) (HouseholdId hid) -> liftIO $ do
SQL.execute conn "UPDATE users SET household_id = ? WHERE id = ?" (hid, uid)
GetUserHouseholds (UserId uid) -> liftIO $ do
rows <-
SQL.query
@@ -138,6 +144,7 @@ runDB conn = interpret $ \_ -> \case
conn
"INSERT INTO memberships (household_id, user_id, role) VALUES (?, ?, ?)"
(unHouseholdId hid, uid, "owner" :: String)
SQL.execute conn "UPDATE users SET household_id = ? WHERE id = ?" (unHouseholdId hid, uid)
pure $ Household hid name (UserId uid) 1
GetMembers hid -> liftIO $ do
members <-
@@ -327,9 +334,9 @@ runDB conn = interpret $ \_ -> \case
Seed -> liftIO $ do
let demoPassword = "password123"
pwHash <- hashPasswordIO demoPassword
SQL.execute conn "INSERT OR IGNORE INTO users (id, display_name, email, password_hash) VALUES (1, 'Alice', 'alice@demo.com', ?)" (Only pwHash)
SQL.execute conn "INSERT OR IGNORE INTO users (id, display_name, email, password_hash) VALUES (2, 'Bob', 'bob@demo.com', ?)" (Only pwHash)
SQL.execute conn "INSERT OR IGNORE INTO users (id, display_name, email, password_hash) VALUES (3, 'Charlie', 'charlie@demo.com', ?)" (Only pwHash)
SQL.execute conn "INSERT OR IGNORE INTO users (id, display_name, email, password_hash, household_id) VALUES (1, 'Alice', 'alice@demo.com', ?, 1)" (Only pwHash)
SQL.execute conn "INSERT OR IGNORE INTO users (id, display_name, email, password_hash, household_id) VALUES (2, 'Bob', 'bob@demo.com', ?, 1)" (Only pwHash)
SQL.execute conn "INSERT OR IGNORE INTO users (id, display_name, email, password_hash, household_id) VALUES (3, 'Charlie', 'charlie@demo.com', ?, 1)" (Only pwHash)
SQL.execute_ conn "INSERT OR IGNORE INTO households (id, name) VALUES (1, 'Demo House')"
SQL.execute_ conn "INSERT OR IGNORE INTO memberships (household_id, user_id, role) VALUES (1, 1, 'owner')"
SQL.execute_ conn "INSERT OR IGNORE INTO memberships (household_id, user_id, role) VALUES (1, 2, 'member')"
@@ -396,7 +403,7 @@ openDatabase path = do
-- | Create all tables if they don't exist.
runMigrations :: SQL.Connection -> IO ()
runMigrations conn' =
runMigrations conn' = do
mapM_
(SQL.execute_ conn')
[ "CREATE TABLE IF NOT EXISTS users (\
@@ -460,6 +467,9 @@ runMigrations conn' =
\ expires_at TEXT NOT NULL,\
\ created_at TEXT NOT NULL DEFAULT (datetime('now')))"
]
-- Add household_id to users (safe to re-run, ignores "duplicate column" error)
SQL.execute_ conn' "ALTER TABLE users ADD COLUMN household_id INTEGER REFERENCES households(id)"
`catch` (\(_ :: IOException) -> pure ())
----------------------------------------------------------------------
-- Convenience wrappers (send through the DB effect)
@@ -474,6 +484,9 @@ createUser d e p = send (CreateUser d e p)
getUser :: (DB :> es) => UserId -> Eff es (Maybe User)
getUser = send . GetUser
setUserHousehold :: (DB :> es) => UserId -> HouseholdId -> Eff es ()
setUserHousehold u = send . SetUserHousehold u
getUserHouseholds :: (DB :> es) => UserId -> Eff es [Household]
getUserHouseholds = send . GetUserHouseholds
src/Sis/Page/Household.hs
+21 -5
View File
@@ -22,6 +22,7 @@ import Sis.Types
import Sis.View.Layout
import Web.Hyperbole
import Web.Hyperbole.Effect.Session
import Web.Hyperbole.HyperView.Forms
import Web.Hyperbole.Page
data HouseholdPage = HouseholdPage
@@ -33,6 +34,7 @@ instance (DB :> es, IOE :> es) => HyperView HouseholdPage es where
= RefreshHousehold
| CreateInviteAction
| RevokeInviteAction InviteId
| CreateHouseholdAction
deriving stock (Generic)
deriving anyclass (ViewAction)
@@ -43,12 +45,24 @@ instance (DB :> es, IOE :> es) => HyperView HouseholdPage es where
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 $ hyper HouseholdPage $ householdView h mems invs
update CreateHouseholdAction = do
form <- formData @HouseholdFormData
mUser <- lookupSession @UserSession
case mUser of
Nothing -> pure (el "Not authenticated")
Just us -> do
let uid = UserId (usUserId us)
h <- createHousehold uid (hfdName form)
let hid = unHouseholdId (householdId h)
mems <- getMembers hid
invs <- getInvites hid
pure $ hyper HouseholdPage $ householdView h mems invs
update CreateInviteAction = do
mUser <- lookupSession @UserSession
case mUser of
@@ -68,11 +82,13 @@ instance (DB :> es, IOE :> es) => HyperView HouseholdPage es where
noHouseholdView :: View HouseholdPage ()
noHouseholdView = do
el @ att "class" nbContainerClass @ att "style" "max-width:480px;margin:4rem auto" $ do
el @ att "class" nbBoxClass @ att "style" "padding:2rem;text-align:center" $ do
el @ att "class" nbBoxClass @ att "style" "padding:2rem" $ do
el @ att "class" nbHeadingClass $ text "Create Your Household"
el @ att "style" "margin-bottom:1rem" $ text "You need a household to get started."
-- Form for household creation would go here
el $ text "Household creation form coming soon"
el @ att "style" "opacity:0.7;margin-bottom:1.5rem" $ text "You need a household to get started."
form CreateHouseholdAction $ do
el @ att "class" nbLabelClass $ text "Household Name"
tag "input" @ att "type" "text" . att "name" "hfdName" . att "class" nbInputClass @ att "style" "width:100%;margin-bottom:1rem" $ none
submit (text "Create Household") @ att "class" nbButtonDefaultClass @ att "style" "width:100%"
householdView :: Household -> [Membership] -> [Invite] -> View HouseholdPage ()
householdView h mems invs = do
src/Sis/Types.hs
+1
View File
@@ -93,6 +93,7 @@ data User = User
, userDisplayName :: Text
, userEmail :: Text
, userPasswordHash :: Text
, userHouseholdId :: Maybe HouseholdId
}
deriving stock (Show, Eq)