From 08b38af137ca98b7a1b453cddde7d1d5d82a626d Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 22 Nov 2024 18:54:08 +0100 Subject: [PATCH] chore(daily): add suggestions to note fiels (WIP) --- .../courses/tutorial/de-de-formal.msg | 2 +- .../categories/courses/tutorial/en-eu.msg | 2 +- src/Handler/School/DayTasks.hs | 103 +++++++++++++++--- src/Handler/Utils/Form.hs | 2 +- 4 files changed, 89 insertions(+), 20 deletions(-) diff --git a/messages/uniworx/categories/courses/tutorial/de-de-formal.msg b/messages/uniworx/categories/courses/tutorial/de-de-formal.msg index f1064aa89..bb07d57ba 100644 --- a/messages/uniworx/categories/courses/tutorial/de-de-formal.msg +++ b/messages/uniworx/categories/courses/tutorial/de-de-formal.msg @@ -56,4 +56,4 @@ TutorialEyeExam: Sehtest TutorialNote: Kursnotiz TutorialDayAttendance day@Text: Anwesenheit #{day} TutorialDayNote day@Text: Anwesenheitsnotiz für #{day} -TutorialParticipantsDayEdits n@Int: #{tshow n} Kursteilnehmer-Tagesnotizen aktualisiert \ No newline at end of file +TutorialParticipantsDayEdits day@Text: Kursteilnehmer-Tagesnotizen aktualisiert für #{day} \ No newline at end of file diff --git a/messages/uniworx/categories/courses/tutorial/en-eu.msg b/messages/uniworx/categories/courses/tutorial/en-eu.msg index b1e027eaa..465b37b9e 100644 --- a/messages/uniworx/categories/courses/tutorial/en-eu.msg +++ b/messages/uniworx/categories/courses/tutorial/en-eu.msg @@ -57,4 +57,4 @@ TutorialEyeExam: Eye exam TutorialNote: Course note TutorialDayAttendance day: Attendance #{day} TutorialDayNote day: Attendance note #{day} -TutorialParticipantsDayEdits n@Int: #{tshow n} course participant day notes updated \ No newline at end of file +TutorialParticipantsDayEdits day: course participant day notes updated for #{day} \ No newline at end of file diff --git a/src/Handler/School/DayTasks.hs b/src/Handler/School/DayTasks.hs index dd11b28ee..58b916f86 100644 --- a/src/Handler/School/DayTasks.hs +++ b/src/Handler/School/DayTasks.hs @@ -33,6 +33,9 @@ import qualified Database.Esqueleto.PostgreSQL.JSON as E hiding ((?.)) import Database.Esqueleto.Utils.TH +-- | Maximal number of suggestions for note fields in Day Task view +maxSuggestions :: Int64 +maxSuggestions = 7 -- 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) @@ -246,7 +249,8 @@ eyeExamField :: (RenderMessage (HandlerSite m) FormMessage, MonadHandler m, Hand eyeExamField = selectField' (Just $ SomeMessage MsgBoolIrrelevant) optionsFinite mkDailyFormColumn :: (RenderMessage UniWorX msg) => Text -> msg -> Lens' DailyTableData a -> ASetter' DailyFormData a -> Field _ a -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData))) -mkDailyFormColumn k msg lg ls f = sortable (Just $ SortingKey $ stripCI k) (i18nCell msg) $ formCell id -- lens focussing on the form result within the larger DBResult; id iff the form delivers the only result of the table +mkDailyFormColumn k msg lg ls f = sortable (Just $ SortingKey $ stripCI k) (i18nCell msg) $ 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 lg -> x) mkUnique -> over (_1.mapped) (ls .~) . over _2 fvWidget <$> mreq f (fsUniq mkUnique k) (Just x) @@ -256,7 +260,8 @@ colParticipantPermitField :: Colonnade Sortable DailyTableData (DBCell _ (FormRe colParticipantPermitField = colParticipantPermitField' _dailyFormDrivingPermit colParticipantPermitField' :: ASetter' a (Maybe UserDrivingPermit) -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData))) -colParticipantPermitField' l = sortable (Just "permit") (i18nCell MsgTutorialDrivingPermit) $ (cellAttrs <>~ [("style","width:1%")]) <$> formCell id -- lens focussing on the form result within the larger DBResult; id iff the form delivers the only result of the table +colParticipantPermitField' l = sortable (Just "permit") (i18nCell MsgTutorialDrivingPermit) $ (cellAttrs <>~ [("style","width:1%")]) <$> 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) @@ -283,11 +288,53 @@ colParticipantEyeExamField' l = sortable (Just "eye-exam") (i18nCell MsgTutorial colParticipantNoteField :: Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData))) colParticipantNoteField = sortable (Just "note-tutorial") (i18nCell MsgTutorialNote) $ (cellAttrs <>~ [("style","width:60%")]) <$> formCell id (views (resultParticipant . _entityKey) return) - (\(view (resultParticipant . _entityVal . _tutorialParticipantNote) -> note) mkUnique -> - over (_1.mapped) ((_dailyFormParticipantNote .~) . assertM (not . null) . fmap Text.strip) . over _2 fvWidget <$> - mopt textField (fsUniq mkUnique "note-tutorial") (Just note) + (\row mkUnique -> + let note = row ^. resultParticipant . _entityVal . _tutorialParticipantNote + cid = row ^. resultCourse . _entityKey + tid = row ^. resultTutorial . _entityKey + in over (_1.mapped) ((_dailyFormParticipantNote .~) . assertM (not . null) . fmap Text.strip) . over _2 fvWidget <$> + mopt (textField & cfStrip & addDatalist (suggsParticipantNote cid tid)) (fsUniq mkUnique "note-tutorial") (Just note) ) +suggsParticipantNote :: CourseId -> TutorialId -> Handler (OptionList Text) +suggsParticipantNote cid tid = memcachedByHere (Just . Right $ 12 * diffSecond) (cid,tid) $ do -- TODO: better memcached key + let qry = do + (prio, tpn) <- E.from $ TutorialParticipant + ( do + tpa <- E.from $ E.table @TutorialParticipant + E.distinct $ pure () + E.where_ $ E.isJust (tpa E.^. TutorialParticipantNote) + E.&&. tpa E.^. TutorialParticipantTutorial E.==. E.val tid + E.limit maxSuggestions + pure (E.val 1, tpa E.^. TutorialParticipantNote) + ) `E.unionAll_` + ( do + (tpa :& tut) <- E.from $ E.table @TutorialParticipant + `E.innerJoin` E.table @Tutorial + `E.on` (\(tpa :& tut) -> tut E.^. TutorialId E.==. tpa E.^. TutorialParticipantTutorial) + E.distinct $ pure () + E.where_ $ E.isJust (tpa E.^. TutorialParticipantNote) + E.&&. tut E.^. TutorialCourse E.==. E.val cid + E.orderBy [E.desc $ tut E.^. TutorialLastChanged] + E.limit maxSuggestions + pure (E.val 2, tpa E.^. TutorialParticipantNote) + ) `E.unionAll_` + ( do + tpa <- E.from $ E.table @TutorialParticipant + E.distinct $ pure () + E.where_ $ E.isJust (tpa E.^. TutorialParticipantNote) + E.limit maxSuggestions + pure (E.val 3, tpa E.^. TutorialParticipantNote) + ) + E.orderBy [E.asc prio, E.asc tpn] + E.limit maxSuggestions + pure tpn + mkOptionsE qry E.unValue (text2message . E.unValue) (toPathPiece . E.unValue) + + +suggsAttentionNote :: Handler (OptionList Textarea) +suggsAttentionNote = error "TODO" + 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) @@ -310,8 +357,16 @@ colAttendanceNoteField dday = sortable (Just "note-attend") (i18nCell $ MsgTutor 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 +-- ) + colParkingField' :: ASetter' a Bool -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData))) -colParkingField' l = sortable (Just "parking") (i18nCell MsgTableUserParkingToken) $ formCell id +colParkingField' l = sortable (Just "parking") (i18nCell MsgTableUserParkingToken) $ formCell + id -- TODO: this should not be id! Refactor to simplify the thrid argument below (views (resultParticipant . _entityKey) return) (\(preview (resultUserDay . _userDayParkingToken) -> parking) mkUnique -> over (_1.mapped) (l .~) . over _2 fvWidget <$> mreq checkBoxField (fsUniq mkUnique "parktoken") parking @@ -368,16 +423,30 @@ mkDailyTable isAdmin ssh nd = do , Just (unCompanyKey -> csh) <- primComp = bookLink <> spacerCell - <> cell (modal (toWidget iconCompanyWarning) (Right -- TODO: use iconCompanyWarning instead! - [whamlet| -

- ^{userWidget row} -

- _{MsgAvsPrimaryCompany}: ^{companyWidget True (csh, csh, False)} - |] - )) - | otherwise = bookLink <> iconCell IconCertificate + <> cell (iconTooltip [whamlet|_{MsgAvsPrimaryCompany}: ^{companyWidget True (csh, csh, False)}|] + (Just IconCompanyWarning) True) + | otherwise = bookLink in result + -- , sortable (Just "booking-company") (i18nCell MsgTableBookingCompany) $ \row -> + -- let bookComp = row ^. resultParticipant . _entityVal . _tutorialParticipantCompany + -- primComp = row ^? resultCompanyId + -- bookLink = cellMaybe companyIdCell bookComp + -- warnIcon = \csh -> iconTooltip [whamlet|_{MsgAvsPrimaryCompany}: ^{companyWidget True (csh, csh, False)}|] (Just IconCompanyWarning) True + -- result + -- | primComp /= bookComp + -- , Just (unCompanyKey -> csh) <- primComp + -- = bookLink + -- <> spacerCell + -- <> cell (modal (warnIcon csh) (Right -- TODO: use iconCompanyWarning instead! + -- [whamlet| + --

+ -- ^{userWidget row} + --

+ -- _{MsgAvsPrimaryCompany}: ^{companyWidget True (csh, csh, False)} + -- |] + -- )) + -- | otherwise = bookLink + -- in result , colUserNameModalHdr MsgCourseParticipant ForProfileDataR , colUserMatriclenr isAdmin , sortable (Just "card-no") (i18nCell MsgAvsCardNo) $ \(preview $ resultUserAvs . _userAvsLastCardNo . _Just -> cn :: Maybe AvsFullCardNo) -> cellMaybe (textCell . tshowAvsFullCardNo) cn @@ -505,8 +574,8 @@ postSchoolDayR ssh nd = do then flip upsertBy_ (UserDay tutorialParticipantUser nd dailyFormParkingToken) -- upsert if a permit was issued else updateBy -- only update to no permit, if the record exists, but do not create a fresh record with parkingToken==False updateUserDay udUq [ UserDayParkingToken =. dailyFormParkingToken] - -- TODO: audit log? - addMessageI Success $ MsgTutorialParticipantsDayEdits $ Map.size resMap + -- audit log? Currently decided against. + addMessageI Success $ MsgTutorialParticipantsDayEdits dday redirect $ SchoolR ssh $ SchoolDayR nd siteLayoutMsg (MsgMenuSchoolDay ssh dday) $ do diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 65fef8d50..f99b6f37a 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -1604,7 +1604,7 @@ mkOptionsE :: forall a r b msg. -> YesodDB UniWorX (OptionList b) mkOptionsE query toExternal toDisplay toInternal = do mr <- getMessageRender - let toOption x = Option <$> (mr <$> toDisplay x) <*> toInternal x <*> toExternal x + let toOption x = (Option . mr <$> toDisplay x) <*> toInternal x <*> toExternal x fmap (mkOptionList . toList) . runConduit $ E.selectSource query .| C.mapM toOption .| C.foldMap Seq.singleton