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

feat: chore creation form with one-off schedule and assignee picker

Browse Source 
- Replaced CNewChore placeholder with a full creation form
- Form includes: chore name (text input), date (date picker for one-off),
  assignee (dropdown with Anyone + household members)
- CNewChore action shows choresViewWithForm (list + form inline)
- CCreateChore processes form data, parses date to ScheduleOneOff,
  parses assignee to ChoreAssignee, calls createChore
- Cancel button (CRefreshChores) returns to list-only view
- parseSchedule: reads YYYY-MM-DD date string into ScheduleOneOff
- parseAssignee: parses 'anyone' or 'user:<id>' into ChoreAssignee
This commit is contained in:
James Brechtel
2026-07-16 09:18:10 -04:00
parent 5485bdfd0b
commit b5ff79fc76
1 changed files with 98 additions and 4 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Sis/Page/Chores.hs
+98 -4
View File
@@ -7,13 +7,16 @@
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-unused-imports -Wno-unused-do-bind -Wno-name-shadowing -Wno-redundant-constraints -Wno-redundant-constraints #-}
{-# OPTIONS_GHC -Wno-unused-imports -Wno-unused-do-bind -Wno-name-shadowing -Wno-redundant-constraints #-}
module Sis.Page.Chores (page) where
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import Data.Text qualified as T
import Data.Time (getCurrentTime)
import Data.Text.Read qualified as TR
import Data.Time (Day)
import Data.Time qualified as Time
import Effectful
import Sis.Database
@@ -21,8 +24,10 @@ import Sis.Route
import Sis.Style (colorGreen, colorRed, colorYellow, nbBadgeClass, nbBoxClass, nbButtonDefaultClass, nbContainerClass, nbHeadingClass, nbInputClass, nbLabelClass, nbListItemClass)
import Sis.Types
import Sis.View.Layout
import Text.Read (readMaybe)
import Web.Hyperbole
import Web.Hyperbole.Effect.Session
import Web.Hyperbole.HyperView.Forms
import Web.Hyperbole.Page
data ChoresPage = ChoresPage
@@ -34,6 +39,7 @@ instance (DB :> es, IOE :> es) => HyperView ChoresPage es where
= CRefreshChores
| CDeleteChore ChoreId
| CNewChore
| CCreateChore
deriving stock (Generic)
deriving anyclass (ViewAction)
@@ -52,8 +58,38 @@ instance (DB :> es, IOE :> es) => HyperView ChoresPage es where
deleteChore (unChoreId cid)
update CRefreshChores
update CNewChore = do
-- TODO: show chore creation form
pure (el "New chore form coming soon")
mUser <- lookupSession @UserSession
case mUser of
Nothing -> pure (el "Not authenticated")
Just us -> do
hhs <- getUserHouseholds (UserId (usUserId us))
case hhs of
[] -> pure $ hyper ChoresPage $ el "No households"
(h : _) -> do
let hid = unHouseholdId (householdId h)
chores' <- getChores hid
mems <- getMembers hid
pure $ hyper ChoresPage $ choresViewWithForm chores' mems
update CCreateChore = do
form <- formData @ChoreFormData
mUser <- lookupSession @UserSession
case mUser of
Nothing -> pure (el "Not authenticated")
Just us -> do
hhs <- getUserHouseholds (UserId (usUserId us))
case hhs of
[] -> pure $ hyper ChoresPage $ el "No households"
(h : _) -> do
let hid = unHouseholdId (householdId h)
let schedule = parseSchedule (cfdStartDate form)
assignee = parseAssignee (cfdAssignee form)
_ <- createChore hid (cfdName form) assignee schedule (cfdNotify form)
chores' <- getChores hid
pure $ hyper ChoresPage $ choresView chores'
----------------------------------------------------------------------
-- Views
----------------------------------------------------------------------
choresView :: [Chore] -> View ChoresPage ()
choresView chores' = do
@@ -65,6 +101,39 @@ choresView chores' = do
then el @ att "style" "opacity:0.5" $ text "No chores yet. Create one to get started!"
else el @ att "class" nbBoxClass $ mapM_ choreRow chores'
-- | Chores list with the creation form shown
choresViewWithForm :: [Chore] -> [Membership] -> View ChoresPage ()
choresViewWithForm chores' mems = do
el @ att "class" nbContainerClass @ att "style" "max-width:960px;margin:0 auto" $ do
el @ att "style" "display:flex;justify-content:space-between;align-items:center;margin-bottom:1rem" $ do
el @ att "class" nbHeadingClass $ text "Chores"
button CRefreshChores @ att "class" nbButtonDefaultClass $ text "Cancel"
-- New chore form
el @ att "class" nbBoxClass @ att "style" "padding:1.5rem;margin-bottom:1.5rem" $ do
el @ att "class" nbHeadingClass $ text "New Chore"
form CCreateChore $ do
el @ att "class" nbLabelClass $ text "Chore Name"
tag "input" @ att "type" "text" . att "name" "cfdName" . att "class" nbInputClass @ att "style" "width:100%;margin-bottom:1rem" $ none
el @ att "class" nbLabelClass $ text "Date (YYYY-MM-DD)"
tag "input" @ att "type" "date" . att "name" "cfdStartDate" . att "class" nbInputClass @ att "style" "width:100%;margin-bottom:1rem" $ none
tag "input" @ att "type" "hidden" . att "name" "cfdScheduleType" . att "value" "one_off" $ none
tag "input" @ att "type" "hidden" . att "name" "cfdPeriod" . att "value" "daily" $ none
tag "input" @ att "type" "hidden" . att "name" "cfdNotify" . att "value" "false" $ none
el @ att "class" nbLabelClass $ text "Assigned To"
tag "select" @ att "name" "cfdAssignee" . att "class" nbInputClass @ att "style" "width:100%;margin-bottom:1rem" $ do
tag "option" @ att "value" "anyone" $ text "Anyone"
mapM_ memberOption mems
submit (text "Create Chore") @ att "class" nbButtonDefaultClass @ att "style" "width:100%"
-- Chores list below the form
if null chores'
then el @ att "style" "opacity:0.5" $ text "No chores yet."
else el @ att "class" nbBoxClass $ mapM_ choreRow chores'
memberOption :: Membership -> View ctx ()
memberOption m = do
let val = "user:" <> T.pack (show (unUserId (membershipUserId m)))
tag "option" @ att "value" val $ text (membershipDisplayName m)
choreRow :: Chore -> View ChoresPage ()
choreRow c = do
el @ att "class" nbListItemClass @ att "style" "display:flex;justify-content:space-between;align-items:center;padding:0.5rem" $ do
@@ -76,6 +145,10 @@ choreRow c = do
button CNewChore @ att "class" nbButtonDefaultClass @ att "style" "font-size:0.8rem;padding:0.25rem 0.5rem" $ text "Edit"
button (CDeleteChore (choreId c)) @ att "class" nbButtonDefaultClass @ att "style" "font-size:0.8rem;padding:0.25rem 0.5rem;background:var(--nb-red)" $ text "Delete"
----------------------------------------------------------------------
-- Helpers
----------------------------------------------------------------------
scheduleBadge :: Schedule -> Text
scheduleBadge ScheduleSometime{} = "sometime"
scheduleBadge ScheduleOneOff{} = "one-off"
@@ -89,6 +162,27 @@ scheduleLabel (ScheduleRecurring p _ mt _ _) =
timePart = maybe "" (" at " <>) mt
in "Recurs " <> pText <> timePart
-- | Parse a date string (YYYY-MM-DD) into a ScheduleOneOff. Falls back to today.
parseSchedule :: Text -> Schedule
parseSchedule t = case readMaybe (T.unpack t) of
Just d -> ScheduleOneOff d Nothing
Nothing -> ScheduleSometime
-- | Parse an assignee value ("anyone" or "user:<id>")
parseAssignee :: Text -> ChoreAssignee
parseAssignee "anyone" = AssigneeAnyone
parseAssignee t
| "user:" `T.isPrefixOf` t =
let uidText = T.drop 5 t
in case TR.decimal uidText of
Right (uid, _) -> AssigneeUser (UserId uid)
Left _ -> AssigneeAnyone
| otherwise = AssigneeAnyone
----------------------------------------------------------------------
-- Page
----------------------------------------------------------------------
page :: (Hyperbole :> es, DB :> es, IOE :> es) => Page es '[ChoresPage]
page = do
mSession <- lookupSession @UserSession