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

- 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

src/Sis/Database.hs

@@ -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, 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) VALUES (2, 'Bob', 'bob@demo.com', ?)" (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) 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 (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

@@ -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."
+            el @ att "style" "opacity:0.7;margin-bottom:1.5rem" $ text "You need a household to get started."
-            -- Form for household creation would go here
+            form CreateHouseholdAction $ do
-            el $ text "Household creation form coming soon"
+                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

@@ -93,6 +93,7 @@ data User = User
     , userDisplayName :: Text
     , userEmail :: Text
     , userPasswordHash :: Text
+    , userHouseholdId :: Maybe HouseholdId
     }
     deriving stock (Show, Eq)