From e1dca7d6b096dfd2207d51d48d4380881f275e22 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 29 Oct 2024 13:38:23 +0100 Subject: [PATCH] chore(day): make form columns compile eventually --- src/Foundation/Type.hs | 4 +- src/Handler/School/DayTasks.hs | 157 ++++++++++++++++++++------------- 2 files changed, 97 insertions(+), 64 deletions(-) diff --git a/src/Foundation/Type.hs b/src/Foundation/Type.hs index 7f6814ea7..d254a2826 100644 --- a/src/Foundation/Type.hs +++ b/src/Foundation/Type.hs @@ -105,8 +105,8 @@ instance HasCookieSettings RegisteredCookie UniWorX where instance (MonadHandler m, HandlerSite m ~ UniWorX) => ReadLogSettings m where readLogSettings = liftIO . readTVarIO =<< getsYesod (view _appLogSettings) - -type DB = YesodDB UniWorX +type DB = YesodDB UniWorX + -- ~ ReaderT SqlBackend (HandlerFor UniWorX) type DBRead = ReaderT SqlReadBackend (HandlerFor UniWorX) type Form x = Html -> MForm (HandlerFor UniWorX) (FormResult x, WidgetFor UniWorX ()) type MsgRenderer = MsgRendererS UniWorX -- see Utils diff --git a/src/Handler/School/DayTasks.hs b/src/Handler/School/DayTasks.hs index a48330c1e..de4680891 100644 --- a/src/Handler/School/DayTasks.hs +++ b/src/Handler/School/DayTasks.hs @@ -34,16 +34,16 @@ import Database.Esqueleto.Utils.TH -data DailyTableAction = DailyActDummy -- just a dummy, since we don't now yet which actions we will be needing - deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) +-- data DailyTableAction = DailyActDummy -- just a dummy, since we don't now yet which actions we will be needing +-- deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) -instance Universe DailyTableAction -instance Finite DailyTableAction -nullaryPathPiece ''DailyTableAction $ camelToPathPiece' 2 -embedRenderMessage ''UniWorX ''DailyTableAction id +-- instance Universe DailyTableAction +-- instance Finite DailyTableAction +-- nullaryPathPiece ''DailyTableAction $ camelToPathPiece' 2 +-- embedRenderMessage ''UniWorX ''DailyTableAction id -data DailyTableActionData = DailyActDummyData - deriving (Eq, Ord, Read, Show, Generic) +-- data DailyTableActionData = DailyActDummyData +-- deriving (Eq, Ord, Read, Show, Generic) -- | partial JSON object to be used for filtering with "@>" -- ensure that a GIN index for the jsonb column is created in Model.Migration.Definitions @@ -153,6 +153,7 @@ type DailyTableOutput = E.SqlQuery , E.SqlExpr (E.Value (Maybe CompanyId)) , E.SqlExpr (E.Value (Maybe [QualificationId])) ) + type DailyTableData = DBRow ( Entity Course , Entity Tutorial @@ -165,6 +166,17 @@ type DailyTableData = DBRow , E.Value (Maybe [QualificationId]) ) +data DailyFormData = DailyFormData + { dailyFormDrivingPermit :: Maybe UserDrivingPermit + , dailyFormEyeExam :: Maybe UserEyeExam + , dailyFormParticipantNote :: Maybe Text + , dailyFormAttendance :: Bool + , dailyFormAttendanceNote :: Maybe Text + , dailyFormParkingToken :: Bool + } deriving (Eq, Show) + +makeLenses_ ''DailyFormData + -- force declarations before this point to avoid staging restrictions $(return []) @@ -233,51 +245,60 @@ drivingPermitField = selectField' Nothing optionsFinite eyeExamField :: (RenderMessage (HandlerSite m) FormMessage, MonadHandler m, HandlerSite m ~ UniWorX) => Field m UserEyeExam eyeExamField = selectField' Nothing optionsFinite -colParticipantPermitField :: ASetter' a (Maybe UserDrivingPermit) -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData))) -colParticipantPermitField l = sortable (Just "permit") (i18nCell MsgTutorialNote) $ formCell id -- lens focussing on the form result within the larger DBResult; id iff the form delivers the only result of the table +colParticipantPermitField :: Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData))) +colParticipantPermitField = colParticipantPermitField' _dailyFormDrivingPermit + +colParticipantPermitField' :: ASetter' a (Maybe UserDrivingPermit) -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData))) +colParticipantPermitField' l = sortable (Just "permit") (i18nCell MsgTutorialNote) $ formCell id -- lens focussing on the form result within the larger DBResult; id iff the form delivers the only result of the table (views (resultParticipant . _entityKey) return) -- generate row identfifiers for use in form result (\(view (resultParticipant . _entityVal . _tutorialParticipantDrivingPermit) -> x) mkUnique -> over (_1.mapped) (l .~) . over _2 fvWidget <$> mopt drivingPermitField (fsUniq mkUnique "permit") (Just x) ) -- Given the row data and a callback to make an input name suitably unique generate the MForm -colParticipantEyeExamField :: ASetter' a (Maybe UserEyeExam) -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData))) -colParticipantEyeExamField l = sortable (Just "permit") (i18nCell MsgTutorialNote) $ formCell id -- lens focussing on the form result within the larger DBResult; id iff the form delivers the only result of the table - (views (resultParticipant . _entityKey) return) -- generate row identfifiers for use in form result +colParticipantEyeExamField :: Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData))) +colParticipantEyeExamField = colParticipantEyeExamField' _dailyFormEyeExam + +colParticipantEyeExamField' :: ASetter' a (Maybe UserEyeExam) -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData))) +colParticipantEyeExamField' l = sortable (Just "permit") (i18nCell MsgTutorialNote) $ formCell id + (views (resultParticipant . _entityKey) return) (\(view (resultParticipant . _entityVal . _tutorialParticipantEyeExam) -> x) mkUnique -> over (_1.mapped) (l .~) . over _2 fvWidget <$> mopt eyeExamField (fsUniq mkUnique "eye-exam") (Just x) - ) -- Given the row data and a callback to make an input name suitably unique generate the MForm + ) -colParticipantNoteField :: ASetter' a (Maybe Text) -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData))) -colParticipantNoteField l = sortable (Just "note-participant") (i18nCell MsgTutorialNote) $ (cellAttrs <>~ [("style","width:60%")]) <$> formCell id -- lens focussing on the form result within the larger DBResult; id iff the form delivers the only result of the table - (views (resultParticipant . _entityKey) return) -- generate row identfifiers for use in form result +colParticipantNoteField :: Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData))) +colParticipantNoteField = sortable (Just "note-participant") (i18nCell MsgTutorialNote) $ (cellAttrs <>~ [("style","width:60%")]) <$> formCell id + (views (resultParticipant . _entityKey) return) (\(view (resultParticipant . _entityVal . _tutorialParticipantNote) -> note) mkUnique -> - over (_1.mapped) ((l .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvWidget <$> + over (_1.mapped) ((_dailyFormParticipantNote .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvWidget <$> mopt textareaField (fsUniq mkUnique "note-participant") (Just $ Textarea <$> note) - ) -- Given the row data and a callback to make an input name suitably unique generate the MForm + ) -colAttendanceField :: Text -> ASetter' a Bool -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData))) -colAttendanceField dday l = sortable (Just "attendance") (i18nCell $ MsgTutorialDayAttendance dday) $ formCell id -- lens focussing on the form result within the larger DBResult; id iff the form delivers the only result of the table - (views (resultParticipant . _entityKey) return) -- generate row identfifiers for use in form result +colAttendanceField :: Text -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData))) +colAttendanceField dday = sortable (Just "attendance") (i18nCell $ MsgTutorialDayAttendance dday) $ formCell id + (views (resultParticipant . _entityKey) return) (\(preview (resultParticipantDay . _tutorialParticipantDayAttendance) -> attendance) mkUnique -> - over (_1.mapped) (l .~) . over _2 fvWidget <$> mreq checkBoxField (fsUniq mkUnique "attendance") attendance - ) -- Given the row data and a callback to make an input name suitably unique generate the MForm + over (_1.mapped) (_dailyFormAttendance .~) . over _2 fvWidget <$> mreq checkBoxField (fsUniq mkUnique "attendance") attendance + ) -colAttendnaceNoteField :: Text -> ASetter' a (Maybe Text) -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData))) -colAttendnaceNoteField dday l = sortable (Just "note-attendance") (i18nCell $ MsgTutorialDayNote dday) $ (cellAttrs <>~ [("style","width:60%")]) <$> formCell id -- lens focussing on the form result within the larger DBResult; id iff the form delivers the only result of the table - (views (resultParticipant . _entityKey) return) -- generate row identfifiers for use in form result +colAttendanceNoteField :: Text -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData))) +colAttendanceNoteField dday = sortable (Just "note-attendance") (i18nCell $ MsgTutorialDayNote dday) $ (cellAttrs <>~ [("style","width:60%")]) <$> formCell id + (views (resultParticipant . _entityKey) return) (\(preview (resultParticipantDay . _tutorialParticipantDayNote) -> note) mkUnique -> - over (_1.mapped) ((l .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvWidget <$> + over (_1.mapped) ((_dailyFormAttendanceNote .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvWidget <$> mopt textareaField (fsUniq mkUnique "note-attendance") (Textarea <<$>> note) - ) -- Given the row data and a callback to make an input name suitably unique generate the MForm + ) -colParkingField :: ASetter' a Bool -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData))) -colParkingField l = sortable (Just "parking") (i18nCell MsgTableUserParkingToken) $ formCell id -- lens focussing on the form result within the larger DBResult; id iff the form delivers the only result of the table - (views (resultParticipant . _entityKey) return) -- generate row identfifiers for use in form result +colParkingField :: Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData))) +colParkingField = colParkingField' _dailyFormParkingToken + +colParkingField' :: ASetter' a Bool -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData))) +colParkingField' l = sortable (Just "parking") (i18nCell MsgTableUserParkingToken) $ formCell id + (views (resultParticipant . _entityKey) return) (\(preview (resultUserDay . _userDayParkingToken) -> parking) mkUnique -> over (_1.mapped) (l .~) . over _2 fvWidget <$> mreq checkBoxField (fsUniq mkUnique "parktoken") parking - ) -- Given the row data and a callback to make an input name suitably unique generate the MForm + ) -mkDailyTable :: Bool -> SchoolId -> Day -> DB (FormResult (DailyTableActionData, Set TutorialId), Widget) +mkDailyTable :: Bool -> SchoolId -> Day -> DB (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData), Widget) mkDailyTable isAdmin ssh nd = do tutLessons <- getDayTutorials' ssh (nd,nd) dday <- formatTime SelFormatDate nd @@ -303,7 +324,7 @@ mkDailyTable isAdmin ssh nd = do return (crs, tut, tpu, usr, avs, udy, tdy, selectCompanyUserPrime usr, associatedQualifications) dbtRowKey = queryParticipant >>> (E.^. TutorialParticipantId) dbtProj = dbtProjId - dbtColonnade = mconcat + dbtColonnade = formColonnade $ mconcat [ -- dbSelect (applying _2) id (return . view (resultTutorial . _entityKey)) sortable (Just "course") (i18nCell MsgFilterCourse) $ \(view $ resultCourse . _entityVal -> c) -> courseCell c , sortable (Just "tutorial") (i18nCell MsgCourseTutorial) $ \row -> @@ -328,7 +349,12 @@ mkDailyTable isAdmin ssh nd = do , sortable (Just "attendance") (i18nCell $ MsgTutorialDayAttendance dday) $ \(preview $ resultParticipantDay . _tutorialParticipantDayAttendance -> x) -> x & cellMaybe tickmarkCell , sortable (Just "note-attend") (i18nCell $ MsgTutorialDayNote dday) $ \(preview $ resultParticipantDay . _tutorialParticipantDayNote . _Just -> x) -> x & cellMaybe textCell , sortable (Just "parking") (i18nCell MsgTableUserParkingToken) $ \(preview $ resultUserDay . _userDayParkingToken -> x) -> maybeCell x tickmarkCell - -- , colParkingField id -- TODO + , colParticipantPermitField + , colParticipantEyeExamField + , colParticipantNoteField + , colAttendanceField dday + , colAttendanceNoteField dday + , colParkingField ] dbtSorting = Map.fromList [ sortUserNameLink queryUser @@ -365,33 +391,40 @@ mkDailyTable isAdmin ssh nd = do dbtCsvEncode = noCsvEncode dbtCsvDecode = Nothing dbtExtraReps = [] - dbtParams = DBParamsForm - { dbParamsFormMethod = POST - , dbParamsFormAction = Nothing -- Just $ SomeRoute currentRoute - , dbParamsFormAttrs = [] - , dbParamsFormSubmit = FormNoSubmit - , dbParamsFormAdditional = \_csrf -> return (FormMissing, mempty) - -- , dbParamsFormSubmit = FormSubmit - -- , dbParamsFormAdditional - -- = let acts :: Map MCTableAction (AForm Handler MCTableActionData) - -- acts = mconcat - -- [ singletonMap MCActDummy $ pure MCActDummyData - -- ] - -- in renderAForm FormStandard - -- $ (, mempty) . First . Just - -- <$> multiActionA acts (fslI MsgTableAction) Nothing - , dbParamsFormEvaluate = liftHandler . runFormPost - , dbParamsFormResult = id - , dbParamsFormIdent = def - } - postprocess :: FormResult (First DailyTableActionData, DBFormResult TutorialId Bool DailyTableData) - -> FormResult ( DailyTableActionData, Set TutorialId) - postprocess inp = do - (First (Just act), jobMap) <- inp - let jobSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) jobMap - return (act, jobSet) + dbtParams = def { dbParamsFormAction = Just $ SomeRoute $ SchoolR ssh $ SchoolDayR nd } + -- dbtParams = DBParamsForm + -- { dbParamsFormMethod = POST + -- , dbParamsFormAction = Nothing -- Just $ SomeRoute currentRoute + -- , dbParamsFormAttrs = [] + -- , dbParamsFormSubmit = FormSubmit + -- , dbParamsFormAdditional = \frag -> do + -- let acts :: Map DailyTableAction (AForm Handler DailyTableActionData) + -- acts = mconcat + -- [ singletonMap DailyActDummy $ pure DailyActDummyData + -- ] + -- (actionRes, action) <- multiActionM acts "" Nothing mempty + -- return ((, mempty) . Last . Just <$> actionRes, toWidget frag <> action) + -- -- , dbParamsFormAdditional + -- -- = let acts :: Map DailyTableAction (AForm Handler DailyTableActionData) + -- -- acts = mconcat + -- -- [ singletonMap DailyActDummy $ pure DailyActDummyData + -- -- ] + -- -- in renderAForm FormStandard + -- -- $ (, mempty) . First . Just + -- -- <$> multiActionA acts (fslI MsgTableAction) Nothing + -- , dbParamsFormEvaluate = liftHandler . runFormPost + -- , dbParamsFormResult = _1 + -- , dbParamsFormIdent = def + -- } + -- postprocess :: FormResult (First DailyTableActionData, DBFormResult TutorialParticipantId Bool DailyTableData) + -- -> FormResult ( DailyTableActionData, Set TutorialId) + -- postprocess inp = do + -- (First (Just act), jobMap) <- inp + -- let jobSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) jobMap + -- return (act, jobSet) psValidator = def & defaultSorting [SortAscBy "user-name", SortAscBy "course", SortAscBy "tutorial"] - over _1 postprocess <$> dbTable psValidator DBTable{..} + -- over _1 postprocess <$> dbTable psValidator DBTable{..} + dbTable psValidator DBTable{..} getSchoolDayR, postSchoolDayR :: SchoolId -> Day -> Handler Html