diff --git a/src/Sis/Page/Chores.hs b/src/Sis/Page/Chores.hs index f8edea2..0c3d1af 100644 --- a/src/Sis/Page/Chores.hs +++ b/src/Sis/Page/Chores.hs @@ -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:") +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