diff --git a/src/Sis/Database.hs b/src/Sis/Database.hs index d5d0aaa..b486370 100644 --- a/src/Sis/Database.hs +++ b/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) 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 diff --git a/src/Sis/Page/Household.hs b/src/Sis/Page/Household.hs index 182433a..6ff69ac 100644 --- a/src/Sis/Page/Household.hs +++ b/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." - -- 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 diff --git a/src/Sis/Types.hs b/src/Sis/Types.hs index 5e0ce36..1de8483 100644 --- a/src/Sis/Types.hs +++ b/src/Sis/Types.hs @@ -93,6 +93,7 @@ data User = User , userDisplayName :: Text , userEmail :: Text , userPasswordHash :: Text + , userHouseholdId :: Maybe HouseholdId } deriving stock (Show, Eq)