From d4f3ce7bf3d208b16f95ab81971b47dfa752939a Mon Sep 17 00:00:00 2001 From: Steffen Date: Fri, 28 Jun 2024 11:26:55 +0200 Subject: [PATCH 1/9] fix(firm): supervisor secondary did not work as intended also, adding company link to secondary supervisors --- src/Handler/Firm.hs | 33 ++++++++++++++++----------------- src/Handler/Utils/Company.hs | 10 +++++----- src/Handler/Utils/Widgets.hs | 11 ++++++++--- templates/profileData.hamlet | 2 +- test/Database/Fill.hs | 8 +++++++- 5 files changed, 37 insertions(+), 27 deletions(-) diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index d5d092777..d6d4c28e2 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -325,34 +325,33 @@ addDefaultSupervisorsAll mutualSupervision cids = do ------------------------------ -- repeatedly useful queries +usrSuperiorCompanies :: E.SqlExpr (Entity Company) -> E.SqlExpr (Entity UserCompany) -> E.SqlQuery () +-- usrSuperiorCompanies :: E.SqlExpr (E.Value CompanyId) -> E.SqlExpr (Entity UserCompany) -> E.SqlQuery (Entity UserCompany) -- possible alternative +usrSuperiorCompanies cmp usr = do + othr <- E.from $ E.table @UserCompany + E.where_ $ othr E.^. UserCompanyPriority E.>. usr E.^. UserCompanyPriority + E.&&. othr E.^. UserCompanyUser E.==. usr E.^. UserCompanyUser + E.&&. othr E.^. UserCompanyCompany E.!=. cmp E.^. CompanyId -- redundant due to > above, but likely performance improving + -- return othr + fromUserCompany :: Maybe (E.SqlExpr (Entity UserCompany) -> E.SqlExpr (E.Value Bool)) -> E.SqlExpr (Entity Company) -> E.SqlQuery () fromUserCompany mbFltr cmpy = do usrCmpy <- E.from $ E.table @UserCompany let basecond = usrCmpy E.^. UserCompanyCompany E.==. cmpy E.^. CompanyId E.where_ $ maybe basecond ((basecond E.&&.).($ usrCmpy)) mbFltr -firmCountUsers :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) -firmCountUsers = E.subSelectCount . fromUserCompany Nothing +firmCountUsers :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) +firmCountUsers = E.subSelectCount . fromUserCompany Nothing -firmCountUsersPrimary :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) -firmCountUsersPrimary cmp = E.subSelectCount $ fromUserCompany (Just primFltr) cmp +firmCountUsersPrimary :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) +firmCountUsersPrimary cmp = E.subSelectCount $ fromUserCompany (Just primFltr) cmp where - primFltr usr = E.notExists (do - othr <- E.from $ E.table @UserCompany - E.where_ $ othr E.^. UserCompanyPriority E.>. usr E.^. UserCompanyPriority - E.&&. othr E.^. UserCompanyUser E.==. usr E.^. UserCompanyUser - E.&&. othr E.^. UserCompanyCompany E.!=. cmp E.^. CompanyId -- redundant due to > above, but likely performance improving - ) + primFltr = E.notExists . usrSuperiorCompanies cmp -firmCountUsersSecondary :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) +firmCountUsersSecondary :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) firmCountUsersSecondary cmp = E.subSelectCount $ fromUserCompany (Just primFltr) cmp where - primFltr usr = E.exists (do - othr <- E.from $ E.table @UserCompany - E.where_ $ othr E.^. UserCompanyPriority E.>. usr E.^. UserCompanyPriority - E.&&. othr E.^. UserCompanyUser E.==. usr E.^. UserCompanyUser - E.&&. othr E.^. UserCompanyCompany E.!=. cmp E.^. CompanyId -- redundant due to > above, but likely performance improving - ) + primFltr = E.exists . usrSuperiorCompanies cmp firmCountSupervisors :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) firmCountSupervisors = E.subSelectCount . fromUserCompany (Just (E.^. UserCompanySupervisor)) diff --git a/src/Handler/Utils/Company.hs b/src/Handler/Utils/Company.hs index 84bcf76e3..d82adf69f 100644 --- a/src/Handler/Utils/Company.hs +++ b/src/Handler/Utils/Company.hs @@ -40,16 +40,16 @@ wgtCompanies = \uid -> do ^{c} $forall c <- otherCmp

- #{c} + ^{c} |] return $ toMaybe (notNull topCmp) resWgt where - procCmp _ [] = (0, [],[]) + procCmp _ [] = (0, [], []) procCmp maxPri ((E.Value cmpSh, E.Value cmpName, E.Value cmpSpr, E.Value cmpPrio) : cs) = - let cmpWgt = companyWidget (cmpSh, cmpName, cmpSpr) - isTop = cmpPrio >= maxPri + let isTop = cmpPrio >= maxPri + cmpWgt = companyWidget isTop (cmpSh, cmpName, cmpSpr) (accPri,accTop,accRem) = procCmp maxPri cs - in (max cmpPrio accPri, bool accTop (cmpWgt : accTop) isTop, bool (cmpName : accRem) accRem isTop) -- lazy evaluation after repmin example + in (max cmpPrio accPri, bool accTop (cmpWgt : accTop) isTop, bool (cmpWgt : accRem) accRem isTop) -- lazy evaluation after repmin example, don't factor out the bool! -- TODO: use this function in company view Handler.Firm #157 -- | add all company supervisors for a given users diff --git a/src/Handler/Utils/Widgets.hs b/src/Handler/Utils/Widgets.hs index 6861e6e32..ef9366550 100644 --- a/src/Handler/Utils/Widgets.hs +++ b/src/Handler/Utils/Widgets.hs @@ -141,15 +141,20 @@ modalAccess wdgtNo wdgtYes writeAccess route = do else wdgtNo -- also see Handler.Utils.Table.Cells.companyCell -companyWidget :: (CompanyShorthand, CompanyName, Bool) -> Widget -companyWidget (csh, cname, isSupervisor) = simpleLink (toWgt name) curl +companyWidget :: Bool -> (CompanyShorthand, CompanyName, Bool) -> Widget +companyWidget isPrimary (csh, cname, isSupervisor) + | isPrimary, isSupervisor = simpleLink (toWgt $ name <> iconSupervisor) curl + | isPrimary = simpleLink (toWgt name ) curl + | isSupervisor = toWgt name <> simpleLink (toWgt iconSupervisor) curl + | otherwise = toWgt name where curl = FirmUsersR csh corg = ciOriginal cname name - | isSupervisor = text2markup (corg <> " ") <> icon IconSupervisor + | isSupervisor = text2markup (corg <> " ") | otherwise = text2markup corg + ---------- -- HEAT -- ---------- diff --git a/templates/profileData.hamlet b/templates/profileData.hamlet index b12eab167..e926c4dcb 100644 --- a/templates/profileData.hamlet +++ b/templates/profileData.hamlet @@ -108,7 +108,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later

_{MsgCompanyPersonalNumber} ^{usrAutomatic CU_UA_UserCompanyPersonalNumber}
- #{companyPersonalNumber} + #{companyPersonalNumber} $maybe compWgt <- companies
_{MsgCompany} diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index a0b3602e3..25e7baf98 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -656,12 +656,18 @@ fillDb = do , let rcShort = CI.mk $ "RC" <> tshow n ] void . insert' $ UserCompany jost fraportAg True True 0 False - void . insert' $ UserCompany svaupel nice True False 0 False + void . insert' $ UserCompany svaupel nice True False 2 False + void . insert' $ UserCompany svaupel ffacil False False 1 False + void . insert' $ UserCompany svaupel bpol True False 2 False + void . insert' $ UserCompany svaupel fraGround True False 1 False void . insert' $ UserCompany gkleen nice False False 1 True void . insert' $ UserCompany gkleen fraGround False True 2 False + void . insert' $ UserCompany gkleen bpol False True 1 False void . insert' $ UserCompany fhamann bpol False False 1 True void . insert' $ UserCompany fhamann ffacil True True 2 True void . insert' $ UserCompany fhamann nice False False 3 False + void . insert' $ UserCompany sbarth nice False False 3 False + void . insert' $ UserCompany sbarth bpol True True 1 True -- need more tests insertMany_ [UserCompany uid fraGround False False 0 True | Entity uid User{userFirstName = "John"} <- matUsers] insertMany_ [UserCompany uid bpol False False 0 False | Entity uid User{userFirstName = "Elizabeth"} <- matUsers] From 6d49ea092b57f8aa233fe0456bdec828dfdd5847 Mon Sep 17 00:00:00 2001 From: Steffen Date: Mon, 1 Jul 2024 16:24:38 +0200 Subject: [PATCH 2/9] chore(profile): towards #169 - distinguished reroute icon - profile cleaned/reordered --- .../personal_settings/de-de-formal.msg | 3 + .../settings/personal_settings/en-eu.msg | 3 + src/Handler/Profile.hs | 170 +++++++++++------- src/Handler/Users.hs | 56 +++--- src/Handler/Utils/Table/Pagination.hs | 54 +++--- src/Utils.hs | 4 + src/Utils/Icon.hs | 15 +- templates/profileData.hamlet | 76 ++------ 8 files changed, 187 insertions(+), 194 deletions(-) diff --git a/messages/uniworx/categories/settings/personal_settings/de-de-formal.msg b/messages/uniworx/categories/settings/personal_settings/de-de-formal.msg index cc01e920d..e263e10e3 100644 --- a/messages/uniworx/categories/settings/personal_settings/de-de-formal.msg +++ b/messages/uniworx/categories/settings/personal_settings/de-de-formal.msg @@ -28,7 +28,10 @@ ProfileCorrections: Auflistung aller zugewiesenen Korrekturen Remarks: Hinweise ProfileSupervisor: Übergeordnete Ansprechpartner +ProfileNoSupervisor: Keine übergeordneten Ansprechpartner vorhanden. ProfileSupervisee: Ist Ansprechpartner für +ProfileNoSupervisee: Ist kein Ansprechpartner für irgendjemand. +ProfileSuperviseeReroute: Umleitungen erfolgen per UserTelephone: Telefon UserMobile: Mobiltelefon diff --git a/messages/uniworx/categories/settings/personal_settings/en-eu.msg b/messages/uniworx/categories/settings/personal_settings/en-eu.msg index b61ac5678..5e72539b9 100644 --- a/messages/uniworx/categories/settings/personal_settings/en-eu.msg +++ b/messages/uniworx/categories/settings/personal_settings/en-eu.msg @@ -28,7 +28,10 @@ ProfileCorrections: List of all assigned corrections Remarks: Remarks ProfileSupervisor: Supervised by +ProfileNoSupervisor: Is not supervised by anynone. ProfileSupervisee: Supervises +ProfileNoSupervisee: Does not supervise anynone. +ProfileSuperviseeReroute: Reroutes reach this supervisor via UserTelephone: Phone UserMobile: Mobile diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index fdc81305b..31beadcf6 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -7,7 +7,7 @@ module Handler.Profile ( getProfileR, postProfileR , getForProfileR, postForProfileR - , getProfileDataR, makeProfileData + , getProfileDataR, makeProfileData , getForProfileDataR , getAuthPredsR, postAuthPredsR , getUserNotificationR, postUserNotificationR @@ -70,11 +70,11 @@ data SettingsForm = SettingsForm , stgDownloadFiles :: Bool , stgWarningDays :: NominalDiffTime , stgShowSex :: Bool - + , stgPinPassword :: Maybe Text , stgPrefersPostal :: Bool , stgPostAddress :: Maybe StoredMarkup - + , stgTelephone :: Maybe Text , stgMobile :: Maybe Text @@ -142,9 +142,9 @@ makeSettingForm template html = do <*> aopt htmlField (fslI MsgPostAddress & setTooltip MsgPostAddressTip) (stgPostAddress <$> template) <*> aopt (textField & cfStrip) (fslI MsgUserTelephone) (stgTelephone <$> template) - <*> aopt (textField & cfStrip) (fslI MsgUserMobile ) (stgMobile <$> template) + <*> aopt (textField & cfStrip) (fslI MsgUserMobile ) (stgMobile <$> template) - <*> examOfficeForm (stgExamOfficeSettings <$> template) + <*> examOfficeForm (stgExamOfficeSettings <$> template) <*> schoolsForm (stgSchools <$> template) <*> notificationForm (stgNotificationSettings <$> template) return (result, widget) -- no validation here, done later by validateSettings @@ -226,7 +226,7 @@ notificationForm template = wFormToAForm $ do let ntfs nt = fslI nt & case nt of _other -> id - + nsForm nt | maybe False ntHidden $ ntSection nt = pure $ notificationAllowed def nt @@ -297,7 +297,7 @@ examOfficeForm template = wFormToAForm $ do | otherwise -> FormSuccess $ Map.singleton kStart (Left nLabel) return (addRes', $(widgetFile "profile/exam-office-labels/add")) - + miCell :: ListPosition -> Either ExamOfficeLabelName ExamOfficeLabelId -> Maybe EOLabelData @@ -366,7 +366,7 @@ validateSettings User{..} = do userDisplayName' <- use _stgDisplayName guardValidation MsgUserDisplayNameInvalid $ userDisplayName == userDisplayName' || -- unchanged or valid (invalid displayNames delivered by LDAP are preserved) - validDisplayName userTitle userFirstName userSurname userDisplayName' + validDisplayName userTitle userFirstName userSurname userDisplayName' userDisplayEmail' <- use _stgDisplayEmail guardValidation (MsgInvalidEmailAddressWith $ CI.original userDisplayEmail') $ @@ -412,7 +412,7 @@ nullaryPathPiece ''ProfileAnchor $ camelToPathPiece' 1 getForProfileR , postForProfileR :: CryptoUUIDUser -> Handler Html getForProfileR = postForProfileR -postForProfileR cID = do +postForProfileR cID = do uid <- decrypt cID user <- runDB $ get404 uid serveProfileR (uid, user) @@ -449,7 +449,7 @@ serveProfileR (uid, user@User{..}) = do , stgShowSex = userShowSex , stgPinPassword = userPinPassword , stgPostAddress = userPostAddress - , stgPrefersPostal = userPrefersPostal + , stgPrefersPostal = userPrefersPostal , stgTelephone = userTelephone , stgMobile = userMobile , stgExamOfficeSettings = ExamOfficeSettings @@ -580,14 +580,50 @@ getProfileDataR = do getForProfileDataR :: CryptoUUIDUser -> Handler Html getForProfileDataR cID = do uid <- decrypt cID - (user,dataWidget) <- runDB $ bind2 (get404 uid) $ makeProfileData . Entity uid + (user,dataWidget) <- runDB $ bind2 (get404 uid) $ makeProfileData . Entity uid defaultLayout $ do setTitleI $ MsgHeadingForProfileData $ userDisplayName user dataWidget +-- data TableHasData = TableHasData{tableHasRows :: Bool, tableWidget :: Widget} +-- a poor man's record subsitute + +{- +type TableHasData = (Bool, Widget) +tableHasRows :: TableHasData -> Bool +tableHasRows = fst +tableWidget :: TableHasData -> Widget +tableWidget = snd +-} + +maybeTable :: (RenderMessage UniWorX a) + => a -> (Bool, Widget) -> Widget +maybeTable m = maybeTable' m Nothing Nothing + +maybeTable' :: (RenderMessage UniWorX a) + => a -> Maybe a -> Maybe Widget -> (Bool, Widget) -> Widget +-- maybeTable' _ Nothing _ (False, _ ) = mempty +-- maybeTable' _ (Just nodata) _ (False, _ ) = +-- [whamlet| +--
+-- _{nodata} +-- |] +-- maybeTable' hdr _ mbRemark (True ,tbl) = +maybeTable' hdr _ mbRemark (_ ,tbl) = + [whamlet| +
+

_{hdr} +
+ ^{tbl} + $maybe remark <- mbRemark + _{MsgProfileRemark} + \ ^{remark} + |] + + makeProfileData :: Entity User -> DB Widget makeProfileData usrEnt@(Entity uid usrVal@User{..}) = do - now <- liftIO getCurrentTime + now <- liftIO getCurrentTime avsId <- entityVal <<$>> getBy (UniqueUserAvsUser uid) let usrAutomatic :: CU_UserAvs_User -> Widget usrAutomatic = updateAutomatic . mayUpdate usrVal avsId . mkCheckUpdate @@ -599,31 +635,31 @@ makeProfileData usrEnt@(Entity uid usrVal@User{..}) = do E.on $ sheet E.^. SheetId E.==. corrector E.^. SheetCorrectorSheet E.where_ $ corrector E.^. SheetCorrectorUser E.==. E.val uid return (course E.^. CourseTerm, course E.^. CourseSchool, course E.^. CourseShorthand) - studies <- E.select $ E.from $ \(studydegree `E.InnerJoin` studyfeat `E.InnerJoin` studyterms) -> do + studies <- E.select $ E.from $ \(studydegree `E.InnerJoin` studyfeat `E.InnerJoin` studyterms) -> do E.on $ studyfeat E.^. StudyFeaturesField E.==. studyterms E.^. StudyTermsId E.on $ studyfeat E.^. StudyFeaturesDegree E.==. studydegree E.^. StudyDegreeId E.where_ $ studyfeat E.^. StudyFeaturesUser E.==. E.val uid return (studyfeat, studydegree, studyterms) companies <- wgtCompanies uid - supervisors' <- E.select $ E.from $ \(spvr `E.InnerJoin` usrSpvr) -> do - E.on $ spvr E.^. UserSupervisorSupervisor E.==. usrSpvr E.^. UserId - E.where_ $ spvr E.^. UserSupervisorUser E.==. E.val uid - E.orderBy [E.asc (usrSpvr E.^. UserDisplayName)] - return (usrSpvr, spvr E.^. UserSupervisorRerouteNotifications) - let numSupervisors = length supervisors' - supervisors = intersperse (text2widget ", ") $ - (\(usr, E.Value reroutCom) -> linkUserWidget ForProfileDataR usr <> bool mempty icnReroute reroutCom) <$> supervisors' - icnReroute = text2widget " " <> toWgt (icon IconLetter) - supervisees' <- E.select $ E.from $ \(spvr `E.InnerJoin` usrSpvr) -> do - E.on $ spvr E.^. UserSupervisorUser E.==. usrSpvr E.^. UserId - E.where_ $ spvr E.^. UserSupervisorSupervisor E.==. E.val uid - return (usrSpvr, spvr E.^. UserSupervisorRerouteNotifications) - let numSupervisees = length supervisees' - supervisees = intersperse (text2widget ", ") $ - (\(usr, E.Value reroutCom) -> linkUserWidget ForProfileDataR usr <> bool mempty icnReroute reroutCom) <$> supervisees' - -- icnReroute = text2widget " " <> toWgt (icon IconLetter) + -- supervisors' <- E.select $ E.from $ \(spvr `E.InnerJoin` usrSpvr) -> do + -- E.on $ spvr E.^. UserSupervisorSupervisor E.==. usrSpvr E.^. UserId + -- E.where_ $ spvr E.^. UserSupervisorUser E.==. E.val uid + -- E.orderBy [E.asc (usrSpvr E.^. UserDisplayName)] + -- return (usrSpvr, spvr E.^. UserSupervisorRerouteNotifications) + -- let numSupervisors = length supervisors' + -- supervisors = intersperse (text2widget ", ") $ + -- (\(usr, E.Value reroutCom) -> linkUserWidget ForProfileDataR usr <> bool mempty icnReroute reroutCom) <$> supervisors' + -- icnReroute = text2widget " " <> toWgt (icon IconReroute) + -- supervisees' <- E.select $ E.from $ \(spvr `E.InnerJoin` usrSpvr) -> do + -- E.on $ spvr E.^. UserSupervisorUser E.==. usrSpvr E.^. UserId + -- E.where_ $ spvr E.^. UserSupervisorSupervisor E.==. E.val uid + -- return (usrSpvr, spvr E.^. UserSupervisorRerouteNotifications) + -- let numSupervisees = length supervisees' + -- supervisees = intersperse (text2widget ", ") $ + -- (\(usr, E.Value reroutCom) -> linkUserWidget ForProfileDataR usr <> bool mempty icnReroute reroutCom) <$> supervisees' + -- -- icnReroute = text2widget " " <> toWgt (icon IconReroute) --Tables - (hasRowsOwnedCourses, ownedCoursesTable) <- mkOwnedCoursesTable uid -- Tabelle mit eigenen Kursen + ownedCoursesTable <- mkOwnedCoursesTable uid -- Tabelle mit eigenen Kursen enrolledCoursesTable <- mkEnrolledCoursesTable uid -- Tabelle mit allen Teilnehmer: Kurs (link), Datum submissionTable <- mkSubmissionTable uid -- Tabelle mit allen Abgaben und Abgabe-Gruppen submissionGroupTable <- mkSubmissionGroupTable uid -- Tabelle mit allen Abgabegruppen @@ -631,16 +667,16 @@ makeProfileData usrEnt@(Entity uid usrVal@User{..}) = do qualificationsTable <- mkQualificationsTable now uid -- Tabelle mit allen Qualifikationen supervisorsTable <- mkSupervisorsTable uid -- Tabelle mit allen Supervisors superviseesTable <- mkSuperviseesTable uid -- Tabelle mit allen Supervisees - let examTable, ownTutorialTable, tutorialTable :: Widget - examTable = i18n MsgPersonalInfoExamAchievementsWip - ownTutorialTable = i18n MsgPersonalInfoOwnTutorialsWip - tutorialTable = i18n MsgPersonalInfoTutorialsWip + -- let examTable, ownTutorialTable, tutorialTable :: Widget + -- examTable = i18n MsgPersonalInfoExamAchievementsWip + -- ownTutorialTable = i18n MsgPersonalInfoOwnTutorialsWip + -- tutorialTable = i18n MsgPersonalInfoTutorialsWip cID <- encrypt uid mCRoute <- getCurrentRoute - showAdminInfo <- pure (mCRoute == Just (AdminUserR cID)) `or2M` hasReadAccessTo (AdminUserR cID) + showAdminInfo <- pure (mCRoute == Just (AdminUserR cID)) `or2M` hasReadAccessTo (AdminUserR cID) tooltipAvsPersNo <- messageI Info MsgAvsPersonNoNotId - tooltipInvalidEmail <- messageI Error MsgInvalidEmailAddress + tooltipInvalidEmail <- messageI Error MsgInvalidEmailAddress let profileRemarks = $(i18nWidgetFile "profile-remarks") return $(widgetFile "profileData") @@ -698,7 +734,7 @@ mkOwnedCoursesTable = -- | Table listing all courses that the given user is enrolled in -mkEnrolledCoursesTable :: UserId -> DB Widget +mkEnrolledCoursesTable :: UserId -> DB (Bool, Widget) mkEnrolledCoursesTable = let withType :: ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant)) -> a) -> ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant)) -> a) @@ -706,7 +742,7 @@ mkEnrolledCoursesTable = validator = def & defaultSorting [SortDescBy "time"] - in \uid -> dbTableWidget' validator + in \uid -> (_1 %~ getAny) <$> dbTableWidget validator DBTable { dbtIdent = "courseMembership" :: Text , dbtSQLQuery = \(course `E.InnerJoin` participant) -> do @@ -750,7 +786,7 @@ mkEnrolledCoursesTable = -- | Table listing all submissions for the given user -mkSubmissionTable :: UserId -> DB Widget +mkSubmissionTable :: UserId -> DB (Bool, Widget) mkSubmissionTable = let dbtIdent = "submissions" :: Text dbtStyle = def @@ -828,14 +864,10 @@ mkSubmissionTable = dbtExtraReps = [] in \uid -> let dbtSQLQuery = dbtSQLQuery' uid dbtSorting = dbtSorting' uid - in dbTableWidget' validator DBTable{..} --- in do dbtSQLQuery <- dbtSQLQuery' --- dbtSorting <- dbtSorting' --- return $ dbTableWidget' validator $ DBTable {..} - + in (_1 %~ getAny) <$> dbTableWidget validator DBTable{..} -- | Table listing all submissions for the given user -mkSubmissionGroupTable :: UserId -> DB Widget +mkSubmissionGroupTable :: UserId -> DB (Bool, Widget) mkSubmissionGroupTable = let dbtIdent = "subGroups" :: Text dbtStyle = def @@ -887,10 +919,10 @@ mkSubmissionGroupTable = dbtCsvDecode = Nothing dbtExtraReps = [] in \uid -> let dbtSQLQuery = dbtSQLQuery' uid - in dbTableWidget' validator DBTable{..} + in (_1 %~ getAny) <$> dbTableWidget validator DBTable{..} -mkCorrectionsTable :: UserId -> DB Widget +mkCorrectionsTable :: UserId -> DB (Bool, Widget) mkCorrectionsTable = let dbtIdent = "corrections" :: Text dbtStyle = def @@ -960,7 +992,7 @@ mkCorrectionsTable = dbtCsvDecode = Nothing dbtExtraReps = [] in \uid -> let dbtSQLQuery = dbtSQLQuery' uid - in dbTableWidget' validator DBTable{..} + in (_1 %~ getAny) <$> dbTableWidget validator DBTable{..} -- | Table listing all qualifications that the given user is enrolled in @@ -977,26 +1009,26 @@ mkQualificationsTable = E.on $ quser E.^. QualificationUserId E.=?. qblock E.?. QualificationUserBlockQualificationUser E.&&. qblock `isLatestBlockBefore` E.val now E.on $ quser E.^. QualificationUserQualification E.==. quali E.^. QualificationId - E.where_ $ quser E.^. QualificationUserUser E.==. E.val uid + E.where_ $ quser E.^. QualificationUserUser E.==. E.val uid return (quali, quser, qblock) , dbtRowKey = \(_quali `E.InnerJoin` quser `E.LeftOuterJoin` _qblock) -> quser E.^. QualificationUserId - , dbtProj = dbtProjId + , dbtProj = dbtProjId , dbtColonnade = mconcat [ colSchool (_dbrOutput . _1 . _entityVal . _qualificationSchool) , sortable (Just "quali") (i18nCell MsgQualificationName) $ qualificationDescrCell <$> view (_dbrOutput . _1 . _entityVal) - , sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ dayCell <$> view (_dbrOutput . _2 . _entityVal . _qualificationUserFirstHeld ) + , sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ dayCell <$> view (_dbrOutput . _2 . _entityVal . _qualificationUserFirstHeld ) , sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh) $ dayCell <$> view (_dbrOutput . _2 . _entityVal . _qualificationUserLastRefresh) , sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) $ dayCell <$> view (_dbrOutput . _2 . _entityVal . _qualificationUserValidUntil ) , sortable (Just "blocked") (i18nCell MsgQualificationValidIndicator & cellTooltip MsgTableQualificationBlockedTooltipSimple) $ \row -> - qualificationValidReasonCell False (utctDay now) (row ^? _dbrOutput . _3 . _Just . _entityVal) (row ^. _dbrOutput . _2 . _entityVal) + qualificationValidReasonCell False (utctDay now) (row ^? _dbrOutput . _3 . _Just . _entityVal) (row ^. _dbrOutput . _2 . _entityVal) ] , dbtSorting = mconcat [ sortSchool $ to (\(quali `E.InnerJoin` _ `E.LeftOuterJoin` _) -> quali E.^. QualificationSchool) - , singletonMap "quali" $ SortColumn $ withType $ \(quali `E.InnerJoin` _ `E.LeftOuterJoin` _) -> quali E.^. QualificationName + , singletonMap "quali" $ SortColumn $ withType $ \(quali `E.InnerJoin` _ `E.LeftOuterJoin` _) -> quali E.^. QualificationName , singletonMap "blocked" $ SortColumn $ withType $ \(_ `E.InnerJoin` _ `E.LeftOuterJoin` qblock) -> qblock E.?. QualificationUserBlockFrom , singletonMap "valid-until" $ SortColumn $ withType $ \(_ `E.InnerJoin` quser `E.LeftOuterJoin` _) -> quser E.^. QualificationUserValidUntil , singletonMap "last-refresh" $ SortColumn $ withType $ \(_ `E.InnerJoin` quser `E.LeftOuterJoin` _) -> quser E.^. QualificationUserLastRefresh - , singletonMap "first-held" $ SortColumn $ withType $ \(_ `E.InnerJoin` quser `E.LeftOuterJoin` _) -> quser E.^. QualificationUserFirstHeld + , singletonMap "first-held" $ SortColumn $ withType $ \(_ `E.InnerJoin` quser `E.LeftOuterJoin` _) -> quser E.^. QualificationUserFirstHeld ] , dbtFilter = mempty , dbtFilterUI = mempty @@ -1027,9 +1059,9 @@ instance HasUser TblSupervisorData where hasUser = _dbrOutput . _1 . _entityVal -- | Table listing all supervisor of the given user -mkSupervisorsTable :: UserId -> DB Widget -mkSupervisorsTable uid = dbTableWidget' validator DBTable{..} - where +mkSupervisorsTable :: UserId -> DB (Bool, Widget) +mkSupervisorsTable uid = over _1 getAny <$> dbTableWidget validator DBTable{..} + where dbtIdent = "userSupervisedBy" :: Text dbtStyle = def @@ -1043,10 +1075,10 @@ mkSupervisorsTable uid = dbTableWidget' validator DBTable{..} dbtColonnade = mconcat [ colUserNameModalHdr MsgTableSupervisor ForProfileDataR , colUserEmail - , sortable (Just "postal-pref") (i18nCell MsgPrefersPostal) $ \(view $ resultUser . _userPrefersPostal -> b) -> iconFixedCell $ iconLetterOrEmail b - , sortable (Just "rerouted") (i18nCell MsgTableRerouteActive) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorRerouteNotifications -> b) -> tickmarkCell b + , sortable (Just "rerouted") (i18nCell MsgTableRerouteActive) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorRerouteNotifications -> b) -> ifIconCell b IconReroute + , sortable (Just "postal-pref") (i18nCell MsgPrefersPostal) $ \(view $ resultUser . _userPrefersPostal -> b) -> iconFixedCell $ iconLetterOrEmail b , sortable (Just "cshort") (i18nCell MsgTableCompany) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorCompany -> mc) -> maybeCell mc (\(unCompanyKey -> c) -> anchorCell (FirmUsersR c) $ citext2widget c) - , sortable (Just "reason") (i18nCell MsgSupervisorReason) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorReason -> mr) -> maybeCell mr textCell + , sortable (Just "reason") (i18nCell MsgSupervisorReason) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorReason -> mr) -> maybeCell mr textCell ] validator = def & defaultSorting [ SortAscBy "cshort", SortAscBy "user-name" ] dbtSorting = mconcat @@ -1055,7 +1087,7 @@ mkSupervisorsTable uid = dbTableWidget' validator DBTable{..} , singletonMap "postal-pref" $ SortColumn $ queryUser >>> (E.^. UserPrefersPostal) , singletonMap "rerouted" $ SortColumn $ queryUserSupervisor >>> (E.^. UserSupervisorRerouteNotifications) , singletonMap "cshort" $ SortColumn $ queryUserSupervisor >>> (E.^. UserSupervisorCompany) - , singletonMap "reason" $ SortColumn $ queryUserSupervisor >>> (E.^. UserSupervisorReason) + , singletonMap "reason" $ SortColumn $ queryUserSupervisor >>> (E.^. UserSupervisorReason) ] dbtFilter = mconcat [ singletonMap & uncurry $ fltrUserNameEmail queryUser @@ -1068,9 +1100,9 @@ mkSupervisorsTable uid = dbTableWidget' validator DBTable{..} -- | Table listing all persons supervised by the given user -mkSuperviseesTable :: UserId -> DB Widget -mkSuperviseesTable uid = dbTableWidget' validator DBTable{..} - where +mkSuperviseesTable :: UserId -> DB (Bool, Widget) +mkSuperviseesTable uid = over _1 getAny <$> dbTableWidget validator DBTable{..} + where dbtIdent = "userSupervisedBy" :: Text dbtStyle = def @@ -1084,10 +1116,10 @@ mkSuperviseesTable uid = dbTableWidget' validator DBTable{..} dbtColonnade = mconcat [ colUserNameModalHdr MsgTableSupervisee ForProfileDataR -- , colUserEmail - -- , sortable (Just "postal-pref") (i18nCell MsgPrefersPostal) $ \(view $ resultUser . _userPrefersPostal -> b) -> iconFixedCell $ iconLetterOrEmail b - , sortable (Just "rerouted") (i18nCell MsgTableRerouteActive) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorRerouteNotifications -> b) -> tickmarkCell b + , sortable (Just "rerouted") (i18nCell MsgTableRerouteActive) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorRerouteNotifications -> b) -> ifIconCell b IconReroute + -- , sortable (Just "postal-pref") (i18nCell MsgPrefersPostal) $ \(view $ resultUser . _userPrefersPostal -> b) -> iconFixedCell $ iconLetterOrEmail b , sortable (Just "cshort") (i18nCell MsgTableCompany) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorCompany -> mc) -> maybeCell mc (\(unCompanyKey -> c) -> anchorCell (FirmUsersR c) $ citext2widget c) - , sortable (Just "reason") (i18nCell MsgSupervisorReason) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorReason -> mr) -> maybeCell mr textCell + , sortable (Just "reason") (i18nCell MsgSupervisorReason) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorReason -> mr) -> maybeCell mr textCell ] validator = def & defaultSorting [ SortAscBy "cshort", SortAscBy "user-name" ] dbtSorting = mconcat @@ -1096,7 +1128,7 @@ mkSuperviseesTable uid = dbTableWidget' validator DBTable{..} , singletonMap "postal-pref" $ SortColumn $ queryUser >>> (E.^. UserPrefersPostal) , singletonMap "rerouted" $ SortColumn $ queryUserSupervisor >>> (E.^. UserSupervisorRerouteNotifications) , singletonMap "cshort" $ SortColumn $ queryUserSupervisor >>> (E.^. UserSupervisorCompany) - , singletonMap "reason" $ SortColumn $ queryUserSupervisor >>> (E.^. UserSupervisorReason) + , singletonMap "reason" $ SortColumn $ queryUserSupervisor >>> (E.^. UserSupervisorReason) ] dbtFilter = mconcat [ singletonMap & uncurry $ fltrUserNameEmail queryUser diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index a335c6923..e52663da0 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -70,15 +70,15 @@ nullaryPathPiece ''UserAction $ camelToPathPiece' 1 embedRenderMessage ''UniWorX ''UserAction id data UserActionData = UserAvsSyncData - | UserLdapSyncData + | UserLdapSyncData | UserHijack - | UserAddSupervisorData { getActionSupervisors :: Set Text, getActionRerouteNotifications :: Bool, getActionSupervisorReason :: Maybe Text } + | UserAddSupervisorData { getActionSupervisors :: Set Text, getActionRerouteNotifications :: Bool, getActionSupervisorReason :: Maybe Text } | UserSetSupervisorData { getActionSupervisors :: Set Text, getActionRerouteNotifications :: Bool, getActionSupervisorReason :: Maybe Text } | UserRemoveSupervisorData | UserRemoveSubordinatesData - + deriving (Eq, Ord, Read, Show, Generic) - + isNotSetSupervisor :: UserActionData -> Bool isNotSetSupervisor UserSetSupervisorData{} = False isNotSetSupervisor _ = True @@ -128,10 +128,10 @@ postUsersR = do return (usrSpvr, spvr E.^. UserSupervisorRerouteNotifications) let supervisors = intersperse (text2widget ", ") $ (\(usr, E.Value reroutCom) -> linkUserWidget ForProfileDataR usr <> bool mempty icnReroute reroutCom) <$> supervisors' - icnReroute = text2widget " " <> toWgt (icon IconLetter) + icnReroute = text2widget " " <> toWgt (icon IconReroute) pure $ mconcat supervisors , sortable (Just "last-login") (i18nCell MsgLastLogin) $ \DBRow{ dbrOutput = Entity _ User{..} } -> maybe mempty dateTimeCell userLastAuthentication - , sortable (Just "auth-ldap") (i18nCell MsgAuthMode) $ \DBRow{ dbrOutput = Entity _ User{..} } -> i18nCell userAuthentication + , sortable (Just "auth-ldap") (i18nCell MsgAuthMode) $ \DBRow{ dbrOutput = Entity _ User{..} } -> i18nCell userAuthentication , sortable (Just "ldap-sync") (i18nCell MsgLdapSynced) $ \DBRow{ dbrOutput = Entity _ User{..} } -> maybe mempty dateTimeCell userLastLdapSynchronisation , flip foldMap universeF $ \function -> sortable (Just $ SortingKey $ CI.mk $ toPathPiece function) (i18nCell function) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do @@ -187,14 +187,14 @@ postUsersR = do return (act, usrSet) acts :: Map UserAction (AForm Handler UserActionData) - acts = mconcat + acts = mconcat [ singletonMap UserLdapSync $ pure UserLdapSyncData , singletonMap UserAvsSync $ pure UserAvsSyncData - , singletonMap UserAddSupervisor $ UserAddSupervisorData + , singletonMap UserAddSupervisor $ UserAddSupervisorData <$> apopt (textField & cfAnySeparatedSet) (fslI MsgTableSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing <*> apopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip) (Just True) <*> aopt textField (fslI MsgSupervisorReason) Nothing - , singletonMap UserSetSupervisor $ UserSetSupervisorData + , singletonMap UserSetSupervisor $ UserSetSupervisorData <$> apopt (textField & cfAnySeparatedSet) (fslI MsgTableSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing <*> apopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip) (Just True) <*> aopt textField (fslI MsgSupervisorReason) Nothing @@ -209,7 +209,7 @@ postUsersR = do , dbtProj = dbtProjId , dbtSorting = Map.fromList $ [ ( SortingKey $ CI.mk $ toPathPiece function - , SortColumn $ \user -> E.subSelect $ E.from $ \uf -> do + , SortColumn $ \user -> E.subSelect $ E.from $ \uf -> do E.where_ $ uf E.^. UserFunctionUser E.==. user E.^. UserId E.&&. uf E.^. UserFunctionFunction E.==. E.val function return (uf E.^. UserFunctionSchool) @@ -254,9 +254,9 @@ postUsersR = do return (usrSpvr E.^. UserDisplayName) ) , ( "system-function" - , SortColumn $ \user -> E.subSelect $ E.from $ \usf -> do + , SortColumn $ \user -> E.subSelect $ E.from $ \usf -> do E.where_ $ usf E.^. UserSystemFunctionUser E.==. user E.^. UserId - return $ usf E.^. UserSystemFunctionFunction + return $ usf E.^. UserSystemFunctionFunction ) ] , dbtFilter = Map.fromList -- OverloadedLists does not work with the templates @@ -265,7 +265,7 @@ postUsersR = do -- if Set.null criteria then E.true else -- TODO: why is this condition not needed? -- -- Set.foldr (\needle acc -> acc E.||. (user E.^. UserDisplayName) `E.hasInfix` needle) eFalse (criterion :: Set.Set Text) -- E.any (\c -> user E.^. UserDisplayName `E.hasInfix` E.val c) criteria - -- ) + -- ) -- , ( "user-ident", FilterColumn $ \user criterion -> case getLast (criterion :: Last Text) of -- Nothing -> E.val True :: E.SqlExpr (E.Value Bool) -- Just needle -> E.castString (user E.^. UserIdent) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%) @@ -300,7 +300,7 @@ postUsersR = do | otherwise -> E.val True :: E.SqlExpr (E.Value Bool) ) , ( "user-company", FilterColumn . E.mkExistsFilter $ \user criterion -> - E.from $ \(usrComp `E.InnerJoin` comp) -> do + E.from $ \(usrComp `E.InnerJoin` comp) -> do let testname = (E.val criterion :: E.SqlExpr (E.Value (CI Text))) `E.isInfixOf` (E.explicitUnsafeCoerceSqlExprValue "citext" (comp E.^. CompanyName) :: E.SqlExpr (E.Value (CI Text))) testnumber nr = E.val nr E.==. comp E.^. CompanyAvsId @@ -317,12 +317,12 @@ postUsersR = do E.&&. E.any (E.hasInfix (usrSpvr E.^. UserDisplayName)) (E.val <$> Set.toList criteria) ) -- , ( "avs-number", FilterColumn $ E.mkExistsFilterWithComma CI.mk $ \user criterion -> -- note that this is an exact filter - -- E.from $ \usrAvs -> -- do + -- E.from $ \usrAvs -> -- do -- E.where_ $ user E.^. UserId E.==. usrAvs E.^. UserAvsUser -- E.&&. ((E.val criterion :: E.SqlExpr (E.Value (CI Text))) E.==. -- (E.explicitUnsafeCoerceSqlExprValue "citext" (usrAvs E.^. UserAvsNoPerson) :: E.SqlExpr (E.Value (CI Text))) ) -- ) - , ( "is-supervisor", FilterColumn $ \user criterion -> case criterion of + , ( "is-supervisor", FilterColumn $ \user criterion -> case criterion of Last (Just True) -> E.exists . E.from $ \usrSpr -> E.where_ $ user E.^. UserId E.==. usrSpr E.^. UserSupervisorSupervisor Last (Just False) -> E.notExists . E.from $ \usrSpr -> E.where_ $ user E.^. UserId E.==. usrSpr E.^. UserSupervisorSupervisor _ -> E.val True :: E.SqlExpr (E.Value Bool) @@ -341,7 +341,7 @@ postUsersR = do , prismAForm (singletonFilter "user-supervisor") mPrev $ aopt textField (fslI MsgTableSupervisor) , prismAForm (singletonFilter "school") mPrev $ aopt (lift `hoistField` selectFieldList schoolOptions) (fslI MsgCourseSchool) , prismAForm (singletonFilter "is-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgUserIsSupervisor) - , prismAForm (singletonFilter "auth-ldap" . maybePrism _PathPiece) mPrev $ aopt (lift `hoistField` selectFieldList [(MsgAuthPWHash "", False), (MsgAuthLDAP, True)]) (fslI MsgAuthMode) + , prismAForm (singletonFilter "auth-ldap" . maybePrism _PathPiece) mPrev $ aopt (lift `hoistField` selectFieldList [(MsgAuthPWHash "", False), (MsgAuthLDAP, True)]) (fslI MsgAuthMode) , prismAForm (singletonFilter "ldap-sync" . maybePrism _PathPiece) mPrev $ aopt utcTimeField (fslI MsgLdapSyncedBefore) ] , dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } @@ -368,10 +368,10 @@ postUsersR = do formResult usersRes $ \case (act, usersSet) | Set.null usersSet && isNotSetSupervisor act -> - addMessageI Info MsgActionNoUsersSelected + addMessageI Info MsgActionNoUsersSelected (UserLdapSyncData, userSet) -> do forM_ userSet $ \uid -> queueJob' $ JobSynchroniseLdapUser uid - addMessageI Success . MsgSynchroniseLdapUserQueued $ Set.size userSet + addMessageI Success . MsgSynchroniseLdapUserQueued $ Set.size userSet redirectKeepGetParams UsersR (UserAvsSyncData, userSet) -> do n <- runDB $ queueAvsUpdateByUID userSet Nothing @@ -379,7 +379,7 @@ postUsersR = do redirectKeepGetParams UsersR (UserHijack, Set.lookupMin -> Just uid) -> hijackUser uid >>= sendResponse - (UserRemoveSupervisorData, userSet) -> do + (UserRemoveSupervisorData, userSet) -> do runDB $ deleteWhere [UserSupervisorUser <-. Set.toList userSet] addMessageI Success $ MsgUsersRemoveSupervisors $ Set.size userSet redirectKeepGetParams UsersR @@ -388,11 +388,11 @@ postUsersR = do addMessageI Success $ MsgUsersRemoveSubordinates $ Set.size userSet redirectKeepGetParams UsersR (act, usersSet) - | isActionSupervisor act -> do + | isActionSupervisor act -> do avsUsers :: Map Text (Maybe UserId) <- sequenceA $ Map.fromSet guessAvsUser $ getActionSupervisors act let (supersFound, supersNotFound) = partition (is _Just . view _2) $ Map.toList avsUsers users = Set.toList usersSet - nrSuperNotFound = length supersNotFound + nrSuperNotFound = length supersNotFound runDB $ do unless (isNotSetSupervisor act) $ deleteWhere [UserSupervisorUser <-. users] putMany [UserSupervisor s u r Nothing (getActionSupervisorReason act) @@ -413,7 +413,7 @@ postUsersR = do runDBJobs . runConduit $ selectSource [] [] .| C.mapM_ (queueDBJob . JobSynchroniseLdapUser . entityKey) addMessageI Success MsgSynchroniseLdapAllUsersQueued redirect UsersR - AllUsersAvsSync -> do + AllUsersAvsSync -> do now <- liftIO getCurrentTime let nowaday = utctDay now n <- runDB $ E.insertSelectWithConflictCount UniqueAvsSyncUser @@ -425,7 +425,7 @@ postUsersR = do -- Ex.<&> Ex.just (E.day E.now_) -- don't use DB time here, since job handler compares with FRADrive clock Ex.<&> E.justVal nowaday ) - ) (\current excluded -> + ) (\current excluded -> [ AvsSyncCreationTime E.=. E.least (current E.^. AvsSyncCreationTime) (excluded E.^. AvsSyncCreationTime) , AvsSyncPause E.=. E.greatest (current E.^. AvsSyncPause) (excluded E.^. AvsSyncPause) ] @@ -450,7 +450,7 @@ hijackUser uid = do setCredsRedirect $ Creds apDummy (CI.original userIdent) [] getAdminHijackUserR :: CryptoUUIDUser -> Handler Html -getAdminHijackUserR cID = do +getAdminHijackUserR cID = do (hijackWgt, hijackEnctype) <- generateFormPost hijackUserForm let hjForm = wrapForm hijackWgt def{ formSubmit = FormNoSubmit, formEncoding = hijackEnctype, formAction = Just . SomeRoute $ AdminHijackUserR cID } uid :: UserId <- decrypt cID @@ -463,7 +463,7 @@ getAdminHijackUserR cID = do |] postAdminHijackUserR :: CryptoUUIDUser -> Handler TypedContent -postAdminHijackUserR cID = do +postAdminHijackUserR cID = do ((hijackRes, _), _) <- runFormPost hijackUserForm $logWarnS "HIJACK" $ "Form Result is: " <> tshow hijackRes uid <- decrypt cID @@ -517,13 +517,13 @@ postAdminUserR uuid = do queueJob' $ JobSynchroniseLdapUser uid addMessageI Success $ MsgSynchroniseLdapUserQueued 1 redirectKeepGetParams $ AdminUserR uuid - ThisUserAvsSync -> do + ThisUserAvsSync -> do n <- runDB $ queueAvsUpdateByUID (Set.singleton uid) Nothing addMessageI Success $ MsgSynchroniseAvsUserQueued $ fromIntegral n redirectKeepGetParams $ AdminUserR uuid -- ThisUserHijack -> do -- redirect $ AdminHijackUserR uuid - let thisUserActWgt = wrapForm thisUserActWgt' def + let thisUserActWgt = wrapForm thisUserActWgt' def { formSubmit = FormNoSubmit , formAction = Just $ SomeRoute $ AdminUserR uuid , formEncoding = thisUserActEnctype diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 91f731f75..10fb0d544 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -84,7 +84,7 @@ import Data.Ratio ((%)) import qualified Data.Foldable as Foldable import qualified Yesod.Form.Functions as Yesod - + import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import qualified Database.Esqueleto.Internal.Internal as E (SqlSelect,unsafeSqlValue) @@ -170,7 +170,7 @@ dbFilterKey ident = toPathPiece . WithIdent ident data SomeExprValue = forall a. PersistField a => SomeExprValue { getSomeExprValue :: E.SqlExpr (E.Value a) } - + data SortColumn t r' = forall a. PersistField a => SortColumn { getSortColumn :: t -> E.SqlExpr (E.Value a) } | forall a. PersistField a => SortColumnNullsInv { getSortColumn :: t -> E.SqlExpr (E.Value a) } | forall a. PersistField a => SortColumnNeverNull { getSortColumn :: t -> E.SqlExpr (E.Value a) } @@ -264,7 +264,7 @@ instance Monoid (DBTProjFilterPost r') where data FilterColumn t fs = forall a. IsFilterColumn t a => FilterColumn a | forall a. IsFilterColumnHandler t a => FilterColumnHandler a | forall a. IsFilterProjected fs a => FilterProjected a - + filterColumn :: FilterColumn t fs -> Maybe ([Text] -> t -> E.SqlExpr (E.Value Bool)) filterColumn (FilterColumn f) = Just $ filterColumn' f @@ -292,9 +292,9 @@ instance IsFilterColumn t cont => IsFilterColumn t (t -> cont) where instance {-# OVERLAPPABLE #-} (PathPiece (Element l), IsFilterColumn t cont, MonoPointed l, Monoid l) => IsFilterColumn t (l -> cont) where filterColumn' cont is' = filterColumn' (cont $ is' ^. mono' _PathPiece) is' - -class IsFilterColumnHandler t a where - filterColumnHandler' :: a -> [Text] -> Handler (t -> E.SqlExpr (E.Value Bool)) + +class IsFilterColumnHandler t a where + filterColumnHandler' :: a -> [Text] -> Handler (t -> E.SqlExpr (E.Value Bool)) instance IsFilterColumnHandler t ([Text] -> Handler (t -> E.SqlExpr (E.Value Bool))) where filterColumnHandler' fin args = fin args @@ -482,7 +482,7 @@ data DBCsvMode | DBCsvAbort makePrisms ''DBCsvMode - + data DBCsvDiff r' csv k' = DBCsvDiffNew { dbCsvNewKey :: Maybe k' @@ -519,7 +519,7 @@ makeLenses_ ''DBCsvException instance (Typeable k', Show k') => Exception (DBCsvException k') - + data DBTProjCtx fs r = DBTProjCtx { dbtProjFilter :: fs , dbtProjRow :: DBRow r @@ -613,7 +613,7 @@ data DBStyle r = DBStyle } data DBSTemplateMode r = DBSTDefault { dbstmNumber :: Int64 -> Bool, dbstmShowNumber :: Int64 -> Bool } - | DBSTCourse + | DBSTCourse (Lens' r (Entity Course)) -- course (Traversal' r (Entity User)) -- lecturers (Lens' r Bool) -- isRegistered @@ -666,7 +666,7 @@ multiFilter key = prism' fromInner fromOuter -- prism' :: (Maybe [v] -> (Map k [v])) -> ((Map k [v]) -> Maybe (Maybe [v])) -> Prism' (Map k [v]) (Maybe [v]) fromInner = maybe Map.empty (Map.singleton key) fromOuter = Just . Map.lookup key - + data DBTCsvEncode r' k' csv = forall exportData filename sheetName. ( ToNamedRecord csv, CsvColumnsExplained csv , DBTableKey k' @@ -750,7 +750,7 @@ dbtProjId :: forall fs r r'. ( fs ~ (), DBRow r ~ r' ) => ReaderT (DBTProjCtx fs r) (MaybeT (ReaderT SqlBackend (HandlerFor UniWorX))) r' dbtProjId = dbtProjId' - + dbtProjSimple' :: forall fs r r' r''. DBRow r'' ~ r' => (r -> DB r'') @@ -1059,7 +1059,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db doSorting <- or2M (getsYesod . views _appBotMitigations $ Set.notMember SettingBotMitigationOnlyLoggedInTableSorting) (is _Just <$> maybeAuthId) - + let sortingOptions = mkOptionList [ Option t' (SortingSetting t d) t' @@ -1112,7 +1112,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db <|> piInput psShortcircuit <- (== Just dbtIdent') <$> lookupCustomHeader HeaderDBTableShortcircuit - + let -- adjustPI = over _piSorting $ guardOnM doSorting -- probably not neccessary; not displaying the links should be enough for now ((errs, PaginationSettings{..}), paginationInput@PaginationInput{..}) @@ -1217,8 +1217,8 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db -- && all (is _Just) filterSql -- psLimit' = bool PagesizeAll psLimit selectPagesize - - filterHandler <- case csvMode of + + filterHandler <- case csvMode of FormSuccess DBCsvImport{} -> return mempty -- don't execute Handler actions for unneeded filters upon csv _import_ _other -> liftHandler $ forM psFilter' $ \(fc,args) -> mapM ($ args) $ filterColumnHandler fc @@ -1240,7 +1240,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db Just ps -> E.where_ $ dbtRowKey t `E.sqlIn` ps -- Note that multiple where_ are indeed concatenated _other -> return () let filterAppT = Map.foldr (\fc expr -> maybe expr ((: expr) . ($ t)) fc) [] - sqlFilters = filterAppT filterHandler <> filterAppT filterSql -- Note that <> on the maps won't work as intended, since keys are present in both + sqlFilters = filterAppT filterHandler <> filterAppT filterSql -- Note that <> on the maps won't work as intended, since keys are present in both unless (null sqlFilters) $ E.where_ $ E.and sqlFilters return (E.unsafeSqlValue "count(*) OVER ()" :: E.SqlExpr (E.Value Int64), dbtRowKey t, res) @@ -1279,7 +1279,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db exData <- hoistMaybe dbtCsvExampleData hdr <- lift $ dbtCsvHeader Nothing exportUrl <- toTextUrl (currentRoute, [(toPathPiece GetCsvExampleData, "")]) - return $(widgetFile "table/csv-example") + return $(widgetFile "table/csv-example") formResult csvMode $ \case DBCsvAbort{} -> do @@ -1470,7 +1470,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db guardM doAltRep cts <- reqAccept <$> getRequest - + altRep <- hoistMaybe <=< asum $ do mRep <- hoistMaybe . selectRep' extraReps' =<< cts return . return $ mRep <&> \case @@ -1520,7 +1520,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db -> State.modify $ (:) (n, beforeSize, cellSize) | otherwise -> return () let rowspanAcc'' = rowspanAcc' - & traverse . _1 %~ pred + & traverse . _1 %~ pred whenIsJust (flattenAnnotated v) $ go rowspanAcc'' compCellSize :: forall h' c. [(Int, Int, Int)] -> [Sized (Maybe Int) h' c] -> Sized (Maybe Int) h' c -> (Int, Maybe Int) @@ -1634,7 +1634,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db addMessageI Success . MsgCsvImportSuccessful $ length acts' E.transactionSave redirect finalDest - + _other -> return ((FormMissing, mempty), mempty) formResult csvImportConfirmRes $ \case (_, BtnCsvImportAbort) -> do @@ -1661,7 +1661,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db setParam :: Text -> Maybe Text -> QueryText -> QueryText setParam key = setParams key . maybeToList - + dbTableWidget :: Monoid x => PSValidator (HandlerFor UniWorX) x @@ -1784,7 +1784,7 @@ anchorCellCM cache routeM widget = anchorCellCM' cache routeM id (const widget) anchorCellM' :: (HasRoute UniWorX url, ToWidget UniWorX wgt, IsDBTable m a) => WidgetFor UniWorX x -> (x -> url) -> (x -> wgt) -> DBCell m a anchorCellM' xM x2route x2widget = linkEitherCellM' xM x2route (x2widget, x2widget) - + anchorCellCM' :: (HasRoute UniWorX url, ToWidget UniWorX wgt, IsDBTable m a, Binary cache) => cache -> WidgetFor UniWorX x -> (x -> url) -> (x -> wgt) -> DBCell m a anchorCellCM' cache xM x2route x2widget = linkEitherCellCM' cache xM x2route (x2widget, x2widget) @@ -1855,7 +1855,7 @@ maybeLinkEitherCellCM' mCache xM x2route (x2widgetAuth,x2widgetUnauth) = cell $ listCell :: (IsDBTable m a, MonoFoldable mono) => mono -> (Element mono -> DBCell m a) -> DBCell m a listCell = listCell' . return - + listCell' :: (IsDBTable m a, MonoFoldable mono) => WriterT a m mono -> (Element mono -> DBCell m a) -> DBCell m a listCell' mkXS mkCell = ilistCell' (otoList <$> mkXS) $ const mkCell @@ -1926,7 +1926,7 @@ dbSelect :: forall x h r i a. (Headedness h, Monoid' x) -> Colonnade h (DBRow r) (DBCell (MForm (HandlerFor UniWorX)) x) -- dbSelect resLens selLens genIndex = Colonnade.singleton (headednessPure $ i18nCell MsgSelectColumn) $ formCell resLens genIndex genForm dbSelect resLens selLens genIndex = Colonnade.singleton (headednessPure $ mempty & cellAttrs <>~ pure ("uw-hide-columns--no-hide","")) $ formCell resLens genIndex genForm - where + where genForm _ mkUnique = do (selResult, selWidget) <- mreq checkBoxField (fsUniq mkUnique "select") (Just False) return (set selLens <$> selResult, [whamlet|^{fvWidget selWidget}|]) @@ -1936,7 +1936,7 @@ dbSelectIf :: forall x h r i a. (Headedness h, Monoid' x) => Lens' x (FormResult (DBFormResult i a (DBRow r))) -> Setter' a Bool -> (DBRow r -> MForm (HandlerFor UniWorX) i) - -> (DBRow r -> Bool) + -> (DBRow r -> Bool) -> Colonnade h (DBRow r) (DBCell (MForm (HandlerFor UniWorX)) x) dbSelectIf resLens selLens genIndex condition = Colonnade.singleton (headednessPure $ mempty & cellAttrs <>~ [("uw-hide-columns--no-hide", mempty)] ) fCell where @@ -1945,9 +1945,9 @@ dbSelectIf resLens selLens genIndex condition = Colonnade.singleton (headednessP (selResult, selWidget) <- mreq checkBoxField ((bool inputDisabled id $ condition row) $ fsUniq mkUnique "select") (Just False) -- produces disabled field, but still checked by master checkbox from header --(selResult, selWidget) <- mreq (bool noField checkBoxField $ condition row) (fsUniq mkUnique "select") (Just False) -- omits field entirely, but also removes master checkbox from header {- Similar to previous: omits field entirely, but also removes master checkbox from header - (selResult, selWidget) <- if condition row + (selResult, selWidget) <- if condition row then mreq checkBoxField (fsUniq mkUnique "select") (Just False) - else return (FormMissing, FieldView "" Nothing "" mempty Nothing False) + else return (FormMissing, FieldView "" Nothing "" mempty Nothing False) -} return (set selLens <$> selResult, [whamlet|^{fvWidget selWidget}|]) diff --git a/src/Utils.hs b/src/Utils.hs index ef274611a..aa3bb03a0 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -412,6 +412,10 @@ citext2widget t = [whamlet|#{CI.original t}|] str2widget :: String -> WidgetFor site () str2widget s = [whamlet|#{s}|] +-- | hamlet does not like quotes +spaceWidget :: WidgetFor site () +spaceWidget = str2widget " " + int2widget :: Int64 -> WidgetFor site () int2widget i = [whamlet|#{tshow i}|] diff --git a/src/Utils/Icon.hs b/src/Utils/Icon.hs index a45611062..6ba582a00 100644 --- a/src/Utils/Icon.hs +++ b/src/Utils/Icon.hs @@ -106,19 +106,21 @@ data Icon | IconBlocked | IconCertificate | IconPrintCenter - | IconLetter + | IconLetter -- only to be used for postal matters | IconAt | IconSupervisor | IconSupervisorForeign + | IconSuperior -- supervisor and head of department -- IconWaitingForUser | IconExpired | IconLocked | IconUnlocked - | IconResetTries -- also see IconReset + | IconResetTries -- also see IconReset | IconCompany | IconEdit | IconUserEdit - -- IconMagic -- indicates automatic updates + -- IconMagic -- indicates automatic updates + | IconReroute -- for notification rerouting deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic) deriving anyclass (Universe, Finite, NFData) @@ -158,7 +160,7 @@ iconText = \case IconSFTHint -> "life-ring" -- for SheetFileType only IconSFTSolution -> "exclamation-circle" -- for SheetFileType only IconSFTMarking -> "check-circle" -- for SheetFileType only - IconEmail -> "envelope" -- envelope is no longer unamibuous, use IconAt or IconLetter if email and postal need to be distinguished + IconEmail -> "envelope" -- envelope is no longer unambiguous, use IconAt or IconLetter if email and postal need to be distinguished IconRegisterTemplate -> "file-alt" IconNoCorrectors -> "user-slash" IconRemoveUser -> "user-slash" @@ -207,6 +209,7 @@ iconText = \case IconAt -> "at" -- alternative for IconEmail to distinguish from IconLetter IconSupervisor -> "head-side" -- must be notably different to user IconSupervisorForeign -> "alien" + IconSuperior -> "user-tie" -- user-crown -- IconWaitingForUser -> "user-cog" -- Waiting on a user to do something IconExpired -> "hourglass-end" IconLocked -> "lock" @@ -216,7 +219,7 @@ iconText = \case IconEdit -> "edit" IconUserEdit -> "user-edit" -- IconMagic -> "wand-magic" - + IconReroute -> "directions" nullaryPathPiece ''Icon $ camelToPathPiece' 1 deriveLift ''Icon @@ -316,6 +319,8 @@ iconExamRegister :: Bool -> Markup iconExamRegister True = icon IconExamRegisterTrue iconExamRegister False = icon IconExamRegisterFalse +-- | indicator whether notifications are sent by letter or email +-- use iconReroute if type of rerouting is unclear iconLetterOrEmail :: Bool -> Markup iconLetterOrEmail True = icon IconLetter iconLetterOrEmail False = icon IconAt diff --git a/templates/profileData.hamlet b/templates/profileData.hamlet index e926c4dcb..eaeafb282 100644 --- a/templates/profileData.hamlet +++ b/templates/profileData.hamlet @@ -114,18 +114,6 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later _{MsgCompany}
^{compWgt} - $if numSupervisors > 0 -
_{MsgProfileSupervisor} - $if numSupervisors > 3 - \ #{numSupervisors} -
- ^{mconcat supervisors} - $if numSupervisees > 0 -
_{MsgProfileSupervisee} - $if length supervisees > 3 - \ #{numSupervisees} -
- ^{mconcat supervisees} $if showAdminInfo
_{MsgUserCreated} @@ -197,67 +185,25 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later $nothing ^{formatTimeW SelFormatDateTime studyFeaturesLastObserved}
-
- $if hasRowsOwnedCourses -
-

_{MsgProfileCourses} -
- ^{ownedCoursesTable} -
-

_{MsgProfileCourseParticipations} -
- ^{enrolledCoursesTable} + ^{maybeTable' MsgProfileSupervisor (Just MsgProfileNoSupervisor) Nothing supervisorsTable} + + ^{maybeTable' MsgProfileSupervisee (Just MsgProfileNoSupervisee) (Just (msg2widget MsgProfileSuperviseeReroute <> toWgt (iconLetterOrEmail userPrefersPostal))) superviseesTable}

_{MsgProfileQualifications}
^{qualificationsTable} -
-

_{MsgProfileCourseExamResults} -
- ^{examTable} + ^{maybeTable MsgProfileCourses ownedCoursesTable} + + ^{maybeTable MsgProfileCourseParticipations enrolledCoursesTable} -
-

_{MsgProfileTutorials} -
- ^{ownTutorialTable} + ^{maybeTable MsgProfileSubmissionGroups submissionGroupTable} -
-

_{MsgProfileTutorialParticipations} -
- ^{tutorialTable} - -
-

_{MsgProfileSubmissionGroups} -
- ^{submissionGroupTable} - -
-

_{MsgProfileSubmissions} -
- ^{submissionTable} - _{MsgProfileRemark} - \ _{MsgProfileGroupSubmissionDates} - -
-

_{MsgTableCorrector} -
- ^{correctionsTable} - - _{MsgProfileRemark} - \ _{MsgProfileCorrectorRemark} - _{MsgProfileCorrections} - -
-

_{MsgProfileSupervisor} -
- ^{supervisorsTable} - -
-

_{MsgProfileSupervisee} -
- ^{superviseesTable} + ^{maybeTable' MsgProfileSubmissions Nothing (Just (msg2widget MsgProfileGroupSubmissionDates)) submissionTable} + + ^{maybeTable' MsgTableCorrector Nothing (Just (msg2widget MsgProfileCorrectorRemark <> simpleLinkI MsgProfileCorrections CorrectionsR)) correctionsTable} + ^{profileRemarks} From 622c01b9bef43668bb56241df3c8128d2baf31b4 Mon Sep 17 00:00:00 2001 From: Steffen Date: Mon, 1 Jul 2024 18:04:25 +0200 Subject: [PATCH 3/9] chore(profile): towards #169 - profile supervison streamlined (WIP) --- .../personal_settings/de-de-formal.msg | 2 +- .../settings/personal_settings/en-eu.msg | 2 +- src/Foundation/I18n.hs | 59 +++++++++---------- src/Handler/News.hs | 22 +++---- src/Handler/Profile.hs | 41 +++++++++---- templates/profileData.hamlet | 2 +- 6 files changed, 71 insertions(+), 57 deletions(-) diff --git a/messages/uniworx/categories/settings/personal_settings/de-de-formal.msg b/messages/uniworx/categories/settings/personal_settings/de-de-formal.msg index e263e10e3..31d8305d1 100644 --- a/messages/uniworx/categories/settings/personal_settings/de-de-formal.msg +++ b/messages/uniworx/categories/settings/personal_settings/de-de-formal.msg @@ -27,7 +27,7 @@ ProfileCorrectorRemark: Die oberhalb angezeigte Tabelle zeigt nur prinzipielle E ProfileCorrections: Auflistung aller zugewiesenen Korrekturen Remarks: Hinweise -ProfileSupervisor: Übergeordnete Ansprechpartner +ProfileSupervisor n@Int m@Int: #{n} #{pluralDE n "übergeordneter" "übergeordnete"} Ansprechpartner#{noneMoreDE m "" ", davon " <> tshow m <> " mit Benachrichtigungsumleitung"} ProfileNoSupervisor: Keine übergeordneten Ansprechpartner vorhanden. ProfileSupervisee: Ist Ansprechpartner für ProfileNoSupervisee: Ist kein Ansprechpartner für irgendjemand. diff --git a/messages/uniworx/categories/settings/personal_settings/en-eu.msg b/messages/uniworx/categories/settings/personal_settings/en-eu.msg index 5e72539b9..9c0947c41 100644 --- a/messages/uniworx/categories/settings/personal_settings/en-eu.msg +++ b/messages/uniworx/categories/settings/personal_settings/en-eu.msg @@ -27,7 +27,7 @@ ProfileCorrectorRemark: The table above only shows registration as a corrector i ProfileCorrections: List of all assigned corrections Remarks: Remarks -ProfileSupervisor: Supervised by +ProfileSupervisor n m: #{pluralENsN n "Supervisor"}#{noneMoreEN m "" " with " <> tshow m <> " active notification rerouting"} ProfileNoSupervisor: Is not supervised by anynone. ProfileSupervisee: Supervises ProfileNoSupervisee: Does not supervise anynone. diff --git a/src/Foundation/I18n.hs b/src/Foundation/I18n.hs index b1ac4ce01..9eab3e2da 100644 --- a/src/Foundation/I18n.hs +++ b/src/Foundation/I18n.hs @@ -39,7 +39,7 @@ module Foundation.I18n , StudyDegreeTerm(..) , ShortStudyFieldType(..) , StudyDegreeTermType(..) - , ErrorResponseTitle(..) + , ErrorResponseTitle(..) , UniWorXMessages(..) , uniworxMessages , unRenderMessage, unRenderMessage', unRenderMessageLenient @@ -88,15 +88,14 @@ pluralDE num singularForm pluralForm | otherwise = pluralForm pluralDEx :: (Eq a, Num a) => Char -> a -> Text -> Text --- ^ @pluralENs n "Monat" = pluralEN n "Monat" "Monate"@ pluralDEx c n t = pluralDE n t $ t `snoc` c --- | like `pluralDEe` but also prefixes with the number +-- | like `pluralDEx` but also prefixes with the number pluralDExN :: (Eq a, Num a, Show a) => Char -> a -> Text -> Text pluralDExN c n t = tshow n <> cons ' ' (pluralDEx c n t) pluralDEe :: (Eq a, Num a) => a -> Text -> Text --- ^ @pluralENs n "Monat" = pluralEN n "Monat" "Monate"@ +-- ^ @pluralDEe n "Monat" = pluralDEe n "Monat" "Monate"@ pluralDEe = pluralDEx 'e' -- | like `pluralDEe` but also prefixes with the number @@ -105,7 +104,7 @@ pluralDEeN = pluralDExN 'e' -- | postfix plural with an 'n' pluralDEn :: (Eq a, Num a) => a -> Text -> Text --- ^ @pluralENs n "Monat" = pluralEN n "Monat" "Monate"@ +-- ^ @pluralENs n "Monat" = pluralEN n "Monat" "Monate"@ pluralDEn = pluralDEx 'n' -- | like `pluralDEn` but also prefixes with the number @@ -124,14 +123,14 @@ noneOneMoreDE num noneText singularForm pluralForm | num == 1 = singularForm | otherwise = pluralForm --- noneMoreDE :: (Eq a, Num a) --- => a -- ^ Count --- -> Text -- ^ None --- -> Text -- ^ Some --- -> Text --- noneMoreDE num noneText someText --- | num == 0 = noneText --- | otherwise = someText +noneMoreDE :: (Eq a, Num a) + => a -- ^ Count + -> Text -- ^ None + -> Text -- ^ Some + -> Text +noneMoreDE num noneText someText + | num == 0 = noneText + | otherwise = someText pluralEN :: (Eq a, Num a) => a -- ^ Count @@ -146,7 +145,7 @@ pluralENs :: (Eq a, Num a) => a -- ^ Count -> Text -- ^ Singular -> Text --- ^ @pluralENs n "foo" = pluralEN n "foo" "foos"@ +-- ^ @pluralENs n "foo" = pluralEN n "foo" "foos"@ pluralENs n t = pluralEN n t $ t `snoc` 's' -- | like `pluralENs` but also prefixes with the number @@ -164,14 +163,14 @@ noneOneMoreEN num noneText singularForm pluralForm | num == 1 = singularForm | otherwise = pluralForm --- noneMoreEN :: (Eq a, Num a) --- => a -- ^ Count --- -> Text -- ^ None --- -> Text -- ^ Some --- -> Text --- noneMoreEN num noneText someText --- | num == 0 = noneText --- | otherwise = someText +noneMoreEN :: (Eq a, Num a) + => a -- ^ Count + -> Text -- ^ None + -> Text -- ^ Some + -> Text +noneMoreEN num noneText someText + | num == 0 = noneText + | otherwise = someText _ordinalEN :: ToMessage a => a @@ -191,20 +190,20 @@ notEN :: Bool -> Text notEN = bool "not" "" {- -- TODO: use this is message eventually --- Commonly used plurals +-- Commonly used plurals data Thing = Person | Examinee deriving (Eq) -thingDE :: Int -> Thing -> Text +thingDE :: Int -> Thing -> Text thingDE num = (tshow num <>) . Text.cons ' ' . thing - where + where thing :: Thing -> Text thing Person = pluralDE num "Person" "Personen" thing Examinee = pluralDE num "Prüfling" "Prüflinge" - -thingEN :: Int -> Thing -> Text + +thingEN :: Int -> Thing -> Text thingEN num t = tshow num <> Text.cons ' ' (thing t) - where + where thing :: Thing -> Text thing Person = pluralENs num "person" thing Examinee = pluralENs num "examinee" @@ -282,7 +281,7 @@ mkMessageAddition ''UniWorX "Avs" "messages/uniworx/categories/avs" "de-de-forma embedRenderMessage ''UniWorX ''LmsStatus (uncurry ((<>) . (<> "Status")) . Text.splitAt 3) -newtype SomeMessages master = SomeMessages [SomeMessage master] +newtype SomeMessages master = SomeMessages [SomeMessage master] deriving newtype (Semigroup, Monoid) instance master ~ master' => RenderMessage master (SomeMessages master') where @@ -621,6 +620,6 @@ unRenderMessageLenient = unRenderMessage' cmp instance Default DateTimeFormatter where def = mkDateTimeFormatter (getTimeLocale' []) def appTZ -instance RenderMessage UniWorX Address where +instance RenderMessage UniWorX Address where renderMessage s l a@Address{addressName = Just aname} = aname <> cons ' ' (renderMessage s l a{addressName=Nothing}) renderMessage _ _ Address{addressEmail = mail} = "<" <> mail <> ">" diff --git a/src/Handler/News.hs b/src/Handler/News.hs index 0399d98c3..2ac689c39 100644 --- a/src/Handler/News.hs +++ b/src/Handler/News.hs @@ -13,7 +13,7 @@ import Handler.SystemMessage import qualified Data.Map.Strict as Map import qualified Data.Set as Set - + import Database.Esqueleto.Utils.TH import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E @@ -315,16 +315,16 @@ newsUpcomingExams uid = do | otherwise -> mempty ] dbtSorting = Map.fromList - [ ("demo-both", SortColumn $ queryCourse &&& queryExam >>> (\(_course,exam)-> exam E.^. ExamName)) - , ("term", SortColumn $ queryCourse >>> (E.^. CourseTerm )) - , ("school", SortColumn $ queryCourse >>> (E.^. CourseSchool )) - , ("course", SortColumn $ queryCourse >>> (E.^. CourseShorthand )) - , ("name", SortColumn $ queryExam >>> (E.^. ExamName )) - , ("time", SortColumn $ queryExam >>> (E.^. ExamStart )) - , ("register-from", SortColumn $ queryExam >>> (E.^. ExamRegisterFrom )) - , ("register-to", SortColumn $ queryExam >>> (E.^. ExamRegisterTo )) - , ("visible", SortColumn $ queryExam >>> (E.^. ExamVisibleFrom )) - , ("registered", SortColumn $ queryExam >>> (\exam -> + [ ("demo-both", SortColumns $ queryCourse &&& queryExam >>> (\(course,exam)-> [SomeExprValue $ course E.^. CourseShorthand, SomeExprValue $ exam E.^. ExamName])) + , ("term", SortColumn $ queryCourse >>> (E.^. CourseTerm )) + , ("school", SortColumn $ queryCourse >>> (E.^. CourseSchool )) + , ("course", SortColumn $ queryCourse >>> (E.^. CourseShorthand )) + , ("name", SortColumn $ queryExam >>> (E.^. ExamName )) + , ("time", SortColumn $ queryExam >>> (E.^. ExamStart )) + , ("register-from", SortColumn $ queryExam >>> (E.^. ExamRegisterFrom )) + , ("register-to", SortColumn $ queryExam >>> (E.^. ExamRegisterTo )) + , ("visible", SortColumn $ queryExam >>> (E.^. ExamVisibleFrom )) + , ("registered", SortColumn $ queryExam >>> (\exam -> E.exists $ E.from $ \registration -> do E.where_ $ registration E.^. ExamRegistrationUser E.==. E.val uid E.where_ $ registration E.^. ExamRegistrationExam E.==. exam E.^. ExamId diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 31beadcf6..c39eb30e4 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -602,14 +602,13 @@ maybeTable m = maybeTable' m Nothing Nothing maybeTable' :: (RenderMessage UniWorX a) => a -> Maybe a -> Maybe Widget -> (Bool, Widget) -> Widget --- maybeTable' _ Nothing _ (False, _ ) = mempty --- maybeTable' _ (Just nodata) _ (False, _ ) = --- [whamlet| ---
--- _{nodata} --- |] --- maybeTable' hdr _ mbRemark (True ,tbl) = -maybeTable' hdr _ mbRemark (_ ,tbl) = +maybeTable' _ Nothing _ (False, _ ) = mempty +maybeTable' _ (Just nodata) _ (False, _ ) = + [whamlet| +
+ _{nodata} + |] +maybeTable' hdr _ mbRemark (True ,tbl) = [whamlet|

_{hdr} @@ -667,6 +666,9 @@ makeProfileData usrEnt@(Entity uid usrVal@User{..}) = do qualificationsTable <- mkQualificationsTable now uid -- Tabelle mit allen Qualifikationen supervisorsTable <- mkSupervisorsTable uid -- Tabelle mit allen Supervisors superviseesTable <- mkSuperviseesTable uid -- Tabelle mit allen Supervisees + let supervisorsWgt :: Widget = + let ((getSum -> nrSupers, getSum -> nrReroute, getSum -> _nrLetter), tWgt) = supervisorsTable + in maybeTable' (MsgProfileSupervisor nrSupers nrReroute) (Just MsgProfileNoSupervisor) Nothing (Any $ nrSupers > 0, tWgt) -- let examTable, ownTutorialTable, tutorialTable :: Widget -- examTable = i18n MsgPersonalInfoExamAchievementsWip -- ownTutorialTable = i18n MsgPersonalInfoOwnTutorialsWip @@ -1059,8 +1061,8 @@ instance HasUser TblSupervisorData where hasUser = _dbrOutput . _1 . _entityVal -- | Table listing all supervisor of the given user -mkSupervisorsTable :: UserId -> DB (Bool, Widget) -mkSupervisorsTable uid = over _1 getAny <$> dbTableWidget validator DBTable{..} +mkSupervisorsTable :: UserId -> DB ((Sum Int, Sum Int, Sum Int), Widget) +mkSupervisorsTable uid = dbTableWidget validator DBTable{..} where dbtIdent = "userSupervisedBy" :: Text dbtStyle = def @@ -1075,8 +1077,15 @@ mkSupervisorsTable uid = over _1 getAny <$> dbTableWidget validator DBTable{..} dbtColonnade = mconcat [ colUserNameModalHdr MsgTableSupervisor ForProfileDataR , colUserEmail - , sortable (Just "rerouted") (i18nCell MsgTableRerouteActive) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorRerouteNotifications -> b) -> ifIconCell b IconReroute - , sortable (Just "postal-pref") (i18nCell MsgPrefersPostal) $ \(view $ resultUser . _userPrefersPostal -> b) -> iconFixedCell $ iconLetterOrEmail b + -- , sortable (Just "rerouted") (i18nCell MsgTableRerouteActive) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorRerouteNotifications -> b) -> indicatorCell <> ifIconCell b IconReroute + -- , sortable (Just "postal-pref") (i18nCell MsgPrefersPostal) $ \(view $ resultUser . _userPrefersPostal -> b) -> iconFixedCell $ iconLetterOrEmail b + , sortable (Just "reroute") (i18nCell MsgTableRerouteActive) $ \row -> + let isReroute = row ^. resultUserSupervisor . _entityVal ._userSupervisorRerouteNotifications + isLetter = row ^. resultUser . _userPrefersPostal + in tellCell (Sum 1, Sum $ fromEnum isReroute, Sum $ fromEnum $ isReroute && isLetter) $ + ifIconCell isReroute IconReroute + <> spacerCell <> + iconFixedCell (iconLetterOrEmail isLetter) , sortable (Just "cshort") (i18nCell MsgTableCompany) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorCompany -> mc) -> maybeCell mc (\(unCompanyKey -> c) -> anchorCell (FirmUsersR c) $ citext2widget c) , sortable (Just "reason") (i18nCell MsgSupervisorReason) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorReason -> mr) -> maybeCell mr textCell ] @@ -1086,6 +1095,11 @@ mkSupervisorsTable uid = over _1 getAny <$> dbTableWidget validator DBTable{..} , singletonMap & uncurry $ sortUserEmail queryUser , singletonMap "postal-pref" $ SortColumn $ queryUser >>> (E.^. UserPrefersPostal) , singletonMap "rerouted" $ SortColumn $ queryUserSupervisor >>> (E.^. UserSupervisorRerouteNotifications) + -- , singletonMap "reroute" $ SortColumn $ queryUserSupervisor &&& queryUser >>> (\(spr,usr) -> mTuple (spr E.^. UserSupervisorRerouteNotifications) (usr E.^. UserPrefersPostal)) + , singletonMap "reroute" $ SortColumns $ \row -> + [ SomeExprValue $ queryUserSupervisor row E.^. UserSupervisorRerouteNotifications + , SomeExprValue $ queryUser row E.^. UserPrefersPostal + ] , singletonMap "cshort" $ SortColumn $ queryUserSupervisor >>> (E.^. UserSupervisorCompany) , singletonMap "reason" $ SortColumn $ queryUserSupervisor >>> (E.^. UserSupervisorReason) ] @@ -1114,7 +1128,8 @@ mkSuperviseesTable uid = over _1 getAny <$> dbTableWidget validator DBTable{..} dbtProj = dbtProjId dbtColonnade = mconcat - [ colUserNameModalHdr MsgTableSupervisee ForProfileDataR + [ sortable Nothing mempty $ const indicatorCell + , colUserNameModalHdr MsgTableSupervisee ForProfileDataR -- , colUserEmail , sortable (Just "rerouted") (i18nCell MsgTableRerouteActive) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorRerouteNotifications -> b) -> ifIconCell b IconReroute -- , sortable (Just "postal-pref") (i18nCell MsgPrefersPostal) $ \(view $ resultUser . _userPrefersPostal -> b) -> iconFixedCell $ iconLetterOrEmail b diff --git a/templates/profileData.hamlet b/templates/profileData.hamlet index eaeafb282..d8e27fd7a 100644 --- a/templates/profileData.hamlet +++ b/templates/profileData.hamlet @@ -186,7 +186,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later ^{formatTimeW SelFormatDateTime studyFeaturesLastObserved}
- ^{maybeTable' MsgProfileSupervisor (Just MsgProfileNoSupervisor) Nothing supervisorsTable} + ^{supervisorsWgt} ^{maybeTable' MsgProfileSupervisee (Just MsgProfileNoSupervisee) (Just (msg2widget MsgProfileSuperviseeReroute <> toWgt (iconLetterOrEmail userPrefersPostal))) superviseesTable} From ff9014ce05d197c1dc0fce0774a640789cb38b26 Mon Sep 17 00:00:00 2001 From: Steffen Date: Tue, 2 Jul 2024 13:20:34 +0200 Subject: [PATCH 4/9] fix(avs): fix superfluous quotes for matriculation numbers on newly created users --- src/Handler/Utils/Avs.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index 7a47218b4..0fce84082 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -537,7 +537,7 @@ createAvsUserById muid api = do , audEmail = persMail & fromMaybe ("AVSNO:" <> cpi ^. _avsInfoPersonNo . from _CI) , audIdent = persMail & fromMaybe ("AVSID:" <> ciShow api ) , audAuth = maybe AuthKindNoLogin (const AuthKindLDAP) internalPersNo - , audMatriculation = cpi ^. _avsInfoPersonNo & Just . tshow + , audMatriculation = cpi ^. _avsInfoPersonNo & Just , audSex = Nothing , audBirthday = cpi ^. _avsInfoDateOfBirth , audMobile = cpi ^. _avsInfoPersonMobilePhoneNo From 9e2f2214ce5c7ee1e8d80e6fa75298b7a70d9043 Mon Sep 17 00:00:00 2001 From: Steffen Date: Tue, 2 Jul 2024 15:27:56 +0200 Subject: [PATCH 5/9] fix(avs): do not associate users by AvsInfoPersonEmail --- src/Handler/Utils/Avs.hs | 12 ++++++------ src/Handler/Utils/AvsUpdate.hs | 2 +- 2 files changed, 7 insertions(+), 7 deletions(-) diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index 0fce84082..b53d1c097 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -484,18 +484,18 @@ createAvsUserById muid api = do case Set.toList contactRes of [] -> throwM $ AvsUserUnknownByAvs api (_:_:_) -> throwM $ AvsUserAmbiguous api - [AvsDataContact{avsContactPersonInfo=cpi, avsContactFirmInfo=firmInfo, avsContactPersonID}] + [adc@AvsDataContact{avsContactPersonInfo=cpi, avsContactFirmInfo=firmInfo, avsContactPersonID}] | avsContactPersonID /= api -> throwM $ AvsIdMismatch api avsContactPersonID | otherwise -> do -- check for matching existing user let internalPersNo :: Maybe Text = cpi ^? _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo - persMail :: Maybe UserEmail = cpi ^? _avsInfoPersonEMail . _Just . from _CI + -- persMail :: Maybe UserEmail = cpi ^? _avsInfoPersonEMail . _Just . from _CI oldUsr <- runDB $ do mbUid <- if isJust muid then return muid else firstJustM $ catMaybes [ internalPersNo <&> (\ipn -> getKeyByFilter [UserCompanyPersonalNumber ==. Just ipn]) -- must ensure filter isnt ==. Nothing - , persMail <&> guessUserByEmail + -- , persMail <&> guessUserByEmail -- this did not work, as unfortunately, superiors are sometimes listed under _avsInfoPersonEMail! ] mbUAvs <- (getBy . UniqueUserAvsUser) `traverseJoin` mbUid return (mbUid, mbUAvs) @@ -533,9 +533,9 @@ createAvsUserById muid api = do , audFirstName = cpi ^. _avsInfoFirstName & Text.strip , audSurname = cpi ^. _avsInfoLastName & Text.strip , audDisplayName = cpi ^. _avsInfoDisplayName - , audDisplayEmail = persMail & fromMaybe mempty - , audEmail = persMail & fromMaybe ("AVSNO:" <> cpi ^. _avsInfoPersonNo . from _CI) - , audIdent = persMail & fromMaybe ("AVSID:" <> ciShow api ) + , audDisplayEmail = adc ^. _avsContactPrimaryEmail . to (fromMaybe mempty) . from _CI + , audEmail = "AVSNO:" <> cpi ^. _avsInfoPersonNo . from _CI + , audIdent = "AVSID:" <> ciShow api , audAuth = maybe AuthKindNoLogin (const AuthKindLDAP) internalPersNo , audMatriculation = cpi ^. _avsInfoPersonNo & Just , audSex = Nothing diff --git a/src/Handler/Utils/AvsUpdate.hs b/src/Handler/Utils/AvsUpdate.hs index 8a88cb6b0..5ff7c55fa 100644 --- a/src/Handler/Utils/AvsUpdate.hs +++ b/src/Handler/Utils/AvsUpdate.hs @@ -109,7 +109,7 @@ data CU_UserAvs_User | CU_UA_UserMatrikelnummer | CU_UA_UserCompanyPersonalNumber | CU_UA_UserLdapPrimaryKey - -- CU_UA_UserDisplayEmail -- use _avsContactPrimaryEmailAddress instead + -- CU_UA_UserDisplayEmail -- use _avsContactPrimaryEmail instead deriving (Show, Eq) instance MkCheckUpdate CU_UserAvs_User where From 7ca3237ad0ce742cc5e6f8d839904149c7146f55 Mon Sep 17 00:00:00 2001 From: Steffen Date: Tue, 2 Jul 2024 16:55:12 +0200 Subject: [PATCH 6/9] chore(profile): towards #169 - only one matrikelnumber - proper update indication for matrikelnumber and pin - only display tables with data in profile - refactor supervision overviews --- .../uniworx/categories/avs/de-de-formal.msg | 3 +- messages/uniworx/categories/avs/en-eu.msg | 4 +- .../personal_settings/de-de-formal.msg | 13 +-- .../settings/personal_settings/en-eu.msg | 13 +-- src/Handler/Profile.hs | 55 ++++++++----- src/Handler/Utils/Table/Cells.hs | 81 ++++++++++--------- templates/profileData.hamlet | 41 ++++++---- 7 files changed, 123 insertions(+), 87 deletions(-) diff --git a/messages/uniworx/categories/avs/de-de-formal.msg b/messages/uniworx/categories/avs/de-de-formal.msg index 19c6684c4..5a3270182 100644 --- a/messages/uniworx/categories/avs/de-de-formal.msg +++ b/messages/uniworx/categories/avs/de-de-formal.msg @@ -4,7 +4,9 @@ AvsPersonInfo: AVS Personendaten AvsPersonId: AVS Personen Id AvsPersonNo: AVS Personennummer +AvsPersonNoNotId: AVS Personennummer dient zur menschlichen Kommunikation mit der Ausweisstelle und darf nicht verwechselt werden mit der maschinell verwendeten AVS Personen Id AvsPersonNoMismatch: AVS Personennummer hat sich geändert und wurde in FRADrive noch nicht aktualisiert +AvsPersonNoDiffers: Es sind derzeit zwei verschiedene AVS Personennummern zugeordnet. Bitte einen Administrator kontaktieren. AvsCardNo: Ausweiskartennummer AvsFirstName: Vorname AvsLastName: Nachname @@ -15,7 +17,6 @@ AvsQueryNeeded: Benötigt Verbindung zum AVS. AvsQueryEmpty: Bitte mindestens ein Anfragefeld ausfüllen! AvsQueryStatusInvalid t@Text: Nur numerische IDs eingeben, durch Komma getrennt! Erhalten: #{show t} AvsLicence: Fahrberechtigung -AvsPersonNoNotId: AVS Personennummer dient zur menschlichen Kommunikation mit der Ausweisstelle und darf nicht verwechselt werden mit der maschinell verwendeten AVS Personen Id AvsTitleLicenceSynch: Abgleich Fahrberechtigungen zwischen AVS und FRADrive BtnAvsRevokeUnknown: Fahrberechtigungen im AVS sofort entziehen BtnAvsImportUnknown: AVS Daten unbekannter Personen importieren diff --git a/messages/uniworx/categories/avs/en-eu.msg b/messages/uniworx/categories/avs/en-eu.msg index f42c75318..1b3a7b5a0 100644 --- a/messages/uniworx/categories/avs/en-eu.msg +++ b/messages/uniworx/categories/avs/en-eu.msg @@ -4,7 +4,9 @@ AvsPersonInfo: AVS person info AvsPersonId: AVS person id AvsPersonNo: AVS person number +AvsPersonNoNotId: AVS person number is used in human communication only and must not be mistaken for the AVS personen id used in machine communications AvsPersonNoMismatch: AVS person number has changed and was not yet updated in FRADrive +AvsPersonNoDiffers: There are currently two differing AVS person numbers associated with this user. Please contact an administrator to resolve this. AvsCardNo: Card number AvsFirstName: First name AvsLastName: Last name @@ -15,7 +17,7 @@ AvsQueryNeeded: AVS connection required. AvsQueryEmpty: At least one query field must be filled! AvsQueryStatusInvalid t: Numeric IDs only, comma seperated! #{show t} AvsLicence: Driving Licence -AvsPersonNoNotId: AVS person number is used in human communication only and must not be mistaken for the AVS personen id used in machine communications + AvsTitleLicenceSynch: Synchronisation driving licences between AVS and FRADrive BtnAvsRevokeUnknown: Revoke AVS driving licences for unknown persons immediately BtnAvsImportUnknown: Import AVS data for unknown persons diff --git a/messages/uniworx/categories/settings/personal_settings/de-de-formal.msg b/messages/uniworx/categories/settings/personal_settings/de-de-formal.msg index 31d8305d1..9512318eb 100644 --- a/messages/uniworx/categories/settings/personal_settings/de-de-formal.msg +++ b/messages/uniworx/categories/settings/personal_settings/de-de-formal.msg @@ -25,13 +25,14 @@ PersonalInfoTutorialsWip: Die Anzeige von Kurse, zu denen Sie angemeldet sind wi ProfileGroupSubmissionDates: Bei Gruppenabgaben wird kein Datum angezeigt, wenn Sie die Gruppenabgabe nie selbst hochgeladen haben. ProfileCorrectorRemark: Die oberhalb angezeigte Tabelle zeigt nur prinzipielle Einteilungen als Korrektor zu einem Übungsblatt. Auch ohne Einteilung können Korrekturen einzeln zugewiesen werden, welche hier dann nicht aufgeführt werden. ProfileCorrections: Auflistung aller zugewiesenen Korrekturen -Remarks: Hinweise +Remarks: Hinweis: -ProfileSupervisor n@Int m@Int: #{n} #{pluralDE n "übergeordneter" "übergeordnete"} Ansprechpartner#{noneMoreDE m "" ", davon " <> tshow m <> " mit Benachrichtigungsumleitung"} -ProfileNoSupervisor: Keine übergeordneten Ansprechpartner vorhanden. -ProfileSupervisee: Ist Ansprechpartner für -ProfileNoSupervisee: Ist kein Ansprechpartner für irgendjemand. -ProfileSuperviseeReroute: Umleitungen erfolgen per +ProfileNoSupervisor: Keine übergeordneten Ansprechpartner vorhanden +ProfileSupervisor n@Int m@Int: #{n} #{pluralDE n "übergeordneter" "übergeordnete"} Ansprechpartner#{noneMoreDE m "" (", davon " <> tshow m <> " mit Benachrichtigungsumleitung")} +ProfileSupervisorRemark n@Int m@Int l@Int: #{m}/#{n} #{pluralDE m "übergeordneter" "übergeordnete"} Ansprechpartner mit Benachrichtigungsumleitung#{noneMoreDE l "" (", davon " <> tshow l <> " mit postalischer Benachrichtigung")} +ProfileNoSupervisee: Ist kein Ansprechpartner für irgendjemand +ProfileSupervisee n@Int m@Int: Ist Ansprechpartner für #{n} #{pluralDE n "Person" "Personen"}#{noneMoreDE m "" (", davon " <> tshow m <> " mit Benachrichtigungsumleitung")} +ProfileSuperviseeRemark n@Int m@Int: Dieser Nutzer ist Ansprechpartner für #{n} #{pluralDE n "Person" "Personen"}#{noneMoreDE m "" (", davon " <> tshow m <> " mit Benachrichtigungsumleitung")} UserTelephone: Telefon UserMobile: Mobiltelefon diff --git a/messages/uniworx/categories/settings/personal_settings/en-eu.msg b/messages/uniworx/categories/settings/personal_settings/en-eu.msg index 9c0947c41..3bbb8cec4 100644 --- a/messages/uniworx/categories/settings/personal_settings/en-eu.msg +++ b/messages/uniworx/categories/settings/personal_settings/en-eu.msg @@ -25,13 +25,14 @@ PersonalInfoTutorialsWip: The feature to display courses you have registered for ProfileGroupSubmissionDates: No date is shown for group submissions if you have never uploaded the submission yourself. ProfileCorrectorRemark: The table above only shows registration as a corrector in principle. Even without registration corrections can be assigned individually and are not listed. ProfileCorrections: List of all assigned corrections -Remarks: Remarks +Remarks: Remark: -ProfileSupervisor n m: #{pluralENsN n "Supervisor"}#{noneMoreEN m "" " with " <> tshow m <> " active notification rerouting"} -ProfileNoSupervisor: Is not supervised by anynone. -ProfileSupervisee: Supervises -ProfileNoSupervisee: Does not supervise anynone. -ProfileSuperviseeReroute: Reroutes reach this supervisor via +ProfileNoSupervisor: Is not supervised by anynone +ProfileSupervisor n m: #{pluralENsN n "supervisor"} #{noneMoreEN m "" ("with " <> tshow m <> " active notification rerouting")} +ProfileSupervisorRemark n@Int m@Int l@Int: #{m}/#{n} #{pluralENs m "supervisor"} with active notification rerouting#{noneMoreEN l "" (", and " <> tshow l <> "of these prefer postal notifications")} +ProfileNoSupervisee: Does not supervise anynone +ProfileSupervisee n m: Supervises #{pluralENsN n "person"} #{noneMoreEN m "" ("with " <> tshow m <> " active notification rerouting")} +ProfileSuperviseeRemark n m: This person supervises #{pluralENsN n "person"}#{noneMoreEN m "" (" with " <> tshow m <> " having active notifications rerouting to this user")} UserTelephone: Phone UserMobile: Mobile diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index c39eb30e4..71c1c2e89 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -665,10 +665,15 @@ makeProfileData usrEnt@(Entity uid usrVal@User{..}) = do correctionsTable <- mkCorrectionsTable uid -- Tabelle mit allen Korrektor-Aufgaben qualificationsTable <- mkQualificationsTable now uid -- Tabelle mit allen Qualifikationen supervisorsTable <- mkSupervisorsTable uid -- Tabelle mit allen Supervisors - superviseesTable <- mkSuperviseesTable uid -- Tabelle mit allen Supervisees + superviseesTable <- mkSuperviseesTable actualPrefersPostal uid -- Tabelle mit allen Supervisees let supervisorsWgt :: Widget = - let ((getSum -> nrSupers, getSum -> nrReroute, getSum -> _nrLetter), tWgt) = supervisorsTable - in maybeTable' (MsgProfileSupervisor nrSupers nrReroute) (Just MsgProfileNoSupervisor) Nothing (Any $ nrSupers > 0, tWgt) + let ((getSum -> nrSupers, getSum -> nrReroute, getSum -> nrLetter), tWgt) = supervisorsTable + in maybeTable' (MsgProfileSupervisor nrSupers nrReroute) (Just MsgProfileNoSupervisor) + (toMaybe (nrReroute > 0) $ msg2widget $ MsgProfileSupervisorRemark nrSupers nrReroute nrLetter) (nrSupers > 0, tWgt) + superviseesWgt :: Widget = + let ((getSum -> nrSubs, getSum -> nrReroute), tWgt) = superviseesTable + in maybeTable' (MsgProfileSupervisee nrSubs nrReroute) (Just MsgProfileNoSupervisee) + (toMaybe (nrReroute > 0) $ msg2widget $ MsgProfileSuperviseeRemark nrSubs nrReroute) (nrSubs > 0, tWgt) -- let examTable, ownTutorialTable, tutorialTable :: Widget -- examTable = i18n MsgPersonalInfoExamAchievementsWip -- ownTutorialTable = i18n MsgPersonalInfoOwnTutorialsWip @@ -677,8 +682,9 @@ makeProfileData usrEnt@(Entity uid usrVal@User{..}) = do cID <- encrypt uid mCRoute <- getCurrentRoute showAdminInfo <- pure (mCRoute == Just (AdminUserR cID)) `or2M` hasReadAccessTo (AdminUserR cID) - tooltipAvsPersNo <- messageI Info MsgAvsPersonNoNotId - tooltipInvalidEmail <- messageI Error MsgInvalidEmailAddress + tooltipAvsPersNo <- messageI Info MsgAvsPersonNoNotId + tooltipAvsPersNoDiffers <- messageI Error MsgAvsPersonNoDiffers + tooltipInvalidEmail <- messageI Error MsgInvalidEmailAddress let profileRemarks = $(i18nWidgetFile "profile-remarks") return $(widgetFile "profileData") @@ -755,7 +761,7 @@ mkEnrolledCoursesTable = , dbtRowKey = \(course `E.InnerJoin` _) -> course E.^. CourseId , dbtProj = dbtProjId <&> _dbrOutput . _2 %~ E.unValue , dbtColonnade = mconcat - [ sortable (Just "term") (i18nCell MsgTableTerm) $ + [ sortable (Just "term") (i18nCell MsgTableTerm) $ fmap addIndicatorCell termCell <$> view (_dbrOutput . _1 . _entityVal . _courseTerm) , sortable (Just "school") (i18nCell MsgTableCourseSchool) . magnify (_dbrOutput . _1 . _entityVal) $ schoolCell <$> view _courseTerm @@ -822,7 +828,7 @@ mkSubmissionTable = <&> _dbrOutput . _4 %~ E.unValue dbtColonnade = mconcat - [ sortable (Just "term") (i18nCell MsgTableTerm) $ + [ sortable (Just "term") (i18nCell MsgTableTerm) $ fmap addIndicatorCell termCell <$> view (_dbrOutput . _1 . _1) , sortable (Just "school") (i18nCell MsgTableCourseSchool) . magnify (_dbrOutput . _1 ) $ schoolCell <$> view _1 @@ -892,7 +898,7 @@ mkSubmissionGroupTable = <&> _dbrOutput . _1 %~ $(E.unValueN 3) dbtColonnade = mconcat - [ sortable (Just "term") (i18nCell MsgTableTerm) $ + [ sortable (Just "term") (i18nCell MsgTableTerm) $ fmap addIndicatorCell termCell <$> view (_dbrOutput . _1 . _1) , sortable (Just "school") (i18nCell MsgTableCourseSchool) . magnify (_dbrOutput . _1 ) $ schoolCell <$> view _1 @@ -957,7 +963,7 @@ mkCorrectionsTable = <&> _dbrOutput . _2 %~ E.unValue dbtColonnade = mconcat - [ sortable (Just "term") (i18nCell MsgTableTerm) $ + [ sortable (Just "term") (i18nCell MsgTableTerm) $ fmap addIndicatorCell termCellCL <$> view (_dbrOutput . _1) , sortable (Just "school") (i18nCell MsgTableCourseSchool) $ schoolCellCL <$> view (_dbrOutput . _1) @@ -1017,7 +1023,7 @@ mkQualificationsTable = , dbtProj = dbtProjId , dbtColonnade = mconcat [ colSchool (_dbrOutput . _1 . _entityVal . _qualificationSchool) - , sortable (Just "quali") (i18nCell MsgQualificationName) $ qualificationDescrCell <$> view (_dbrOutput . _1 . _entityVal) + , sortable (Just "quali") (i18nCell MsgQualificationName) $ qualificationDescrCell <$> view (_dbrOutput . _1 . _entityVal) , sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ dayCell <$> view (_dbrOutput . _2 . _entityVal . _qualificationUserFirstHeld ) , sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh) $ dayCell <$> view (_dbrOutput . _2 . _entityVal . _qualificationUserLastRefresh) , sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) $ dayCell <$> view (_dbrOutput . _2 . _entityVal . _qualificationUserValidUntil ) @@ -1083,9 +1089,9 @@ mkSupervisorsTable uid = dbTableWidget validator DBTable{..} let isReroute = row ^. resultUserSupervisor . _entityVal ._userSupervisorRerouteNotifications isLetter = row ^. resultUser . _userPrefersPostal in tellCell (Sum 1, Sum $ fromEnum isReroute, Sum $ fromEnum $ isReroute && isLetter) $ - ifIconCell isReroute IconReroute - <> spacerCell <> - iconFixedCell (iconLetterOrEmail isLetter) + if isReroute + then iconCell IconReroute <> spacerCell <> iconFixedCell (iconLetterOrEmail isLetter) + else mempty , sortable (Just "cshort") (i18nCell MsgTableCompany) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorCompany -> mc) -> maybeCell mc (\(unCompanyKey -> c) -> anchorCell (FirmUsersR c) $ citext2widget c) , sortable (Just "reason") (i18nCell MsgSupervisorReason) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorReason -> mr) -> maybeCell mr textCell ] @@ -1114,8 +1120,8 @@ mkSupervisorsTable uid = dbTableWidget validator DBTable{..} -- | Table listing all persons supervised by the given user -mkSuperviseesTable :: UserId -> DB (Bool, Widget) -mkSuperviseesTable uid = over _1 getAny <$> dbTableWidget validator DBTable{..} +mkSuperviseesTable ::Bool -> UserId -> DB ((Sum Int, Sum Int), Widget) +mkSuperviseesTable userPrefersPostal uid = dbTableWidget validator DBTable{..} where dbtIdent = "userSupervisedBy" :: Text dbtStyle = def @@ -1127,12 +1133,15 @@ mkSuperviseesTable uid = over _1 getAny <$> dbTableWidget validator DBTable{..} dbtRowKey (_ `E.InnerJoin` spr) = spr E.^. UserSupervisorId dbtProj = dbtProjId + iconCellLetterOrEmail = spacerCell <> iconFixedCell (iconLetterOrEmail userPrefersPostal) -- only notification type of supervisor matters here dbtColonnade = mconcat - [ sortable Nothing mempty $ const indicatorCell - , colUserNameModalHdr MsgTableSupervisee ForProfileDataR - -- , colUserEmail - , sortable (Just "rerouted") (i18nCell MsgTableRerouteActive) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorRerouteNotifications -> b) -> ifIconCell b IconReroute + [ colUserNameModalHdr MsgTableSupervisee ForProfileDataR + , colUserEmail + -- , sortable (Just "rerouted") (i18nCell MsgTableRerouteActive) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorRerouteNotifications -> b) -> ifIconCell b IconReroute -- , sortable (Just "postal-pref") (i18nCell MsgPrefersPostal) $ \(view $ resultUser . _userPrefersPostal -> b) -> iconFixedCell $ iconLetterOrEmail b + , sortable (Just "reroute") (i18nCell MsgTableRerouteActive) $ \row -> + let isReroute = row ^. resultUserSupervisor . _entityVal ._userSupervisorRerouteNotifications + in tellCell (Sum 1, Sum $ fromEnum isReroute) $ boolCell isReroute $ iconCell IconReroute <> iconCellLetterOrEmail , sortable (Just "cshort") (i18nCell MsgTableCompany) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorCompany -> mc) -> maybeCell mc (\(unCompanyKey -> c) -> anchorCell (FirmUsersR c) $ citext2widget c) , sortable (Just "reason") (i18nCell MsgSupervisorReason) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorReason -> mr) -> maybeCell mr textCell ] @@ -1140,8 +1149,12 @@ mkSuperviseesTable uid = over _1 getAny <$> dbTableWidget validator DBTable{..} dbtSorting = mconcat [ singletonMap & uncurry $ sortUserNameLink queryUser , singletonMap & uncurry $ sortUserEmail queryUser - , singletonMap "postal-pref" $ SortColumn $ queryUser >>> (E.^. UserPrefersPostal) - , singletonMap "rerouted" $ SortColumn $ queryUserSupervisor >>> (E.^. UserSupervisorRerouteNotifications) + -- , singletonMap "postal-pref" $ SortColumn $ queryUser >>> (E.^. UserPrefersPostal) + -- , singletonMap "rerouted" $ SortColumn $ queryUserSupervisor >>> (E.^. UserSupervisorRerouteNotifications) + , singletonMap "reroute" $ SortColumns $ \row -> + [ SomeExprValue $ queryUserSupervisor row E.^. UserSupervisorRerouteNotifications + , SomeExprValue $ queryUser row E.^. UserPrefersPostal + ] , singletonMap "cshort" $ SortColumn $ queryUserSupervisor >>> (E.^. UserSupervisorCompany) , singletonMap "reason" $ SortColumn $ queryUserSupervisor >>> (E.^. UserSupervisorReason) ] diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index 18b2186fb..1c62f37a8 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -14,7 +14,7 @@ import Handler.Utils.DateTime import Handler.Utils.Widgets import Handler.Utils.Occurrences import Handler.Utils.LMS (lmsUserStatusWidget) -import Handler.Utils.Qualification (isValidQualification) +import Handler.Utils.Qualification (isValidQualification) type CourseLink = (TermId, SchoolId, CourseShorthand) -- TODO: Refactor with WithHoles ! @@ -41,16 +41,23 @@ cellTell = flip tellCell indicatorCell :: IsDBTable m Any => DBCell m Any -- For dbTables that return a Bool to indicate content indicatorCell = writerCell . tell $ Any True +addIndicatorCell :: IsDBTable m Any => DBCell m Any -> DBCell m Any +addIndicatorCell = tellCell $ Any True + writerCell :: IsDBTable m w => WriterT w m () -> DBCell m w writerCell act = mempty & cellContents %~ (<* act) --- for documentation purposes +-- for documentation purposes cellMaybe :: IsDBTable m b => (a -> DBCell m b) -> Maybe a -> DBCell m b cellMaybe = foldMap maybeCell :: IsDBTable m b => Maybe a -> (a -> DBCell m b) -> DBCell m b maybeCell = flip foldMap +boolCell :: IsDBTable m b => Bool -> DBCell m b -> DBCell m b +boolCell True c = c +boolCell False _ = mempty + htmlCell :: (IsDBTable m a, ToMarkup c) => c -> DBCell m a htmlCell = cell . toWidget . toMarkup @@ -62,7 +69,7 @@ sqlCell :: (IsDBTable (YesodDB UniWorX) a) => YesodDB UniWorX Widget -> DBCell ( sqlCell act = mempty & cellContents .~ lift act -- TODO: Formulate variant of sqlCell that types for tables having actions, i.e. MForm istead of YesodDB? --- sqlCell' :: (IsDBTable (MForm Handler) a) => _ -> DBCell (MForm Handler) a +-- sqlCell' :: (IsDBTable (MForm Handler) a) => _ -> DBCell (MForm Handler) a -- sqlCell' = flip (set' cellContents) mempty -- | Highlight table cells with warning: Is not yet implemented in frontend. @@ -158,14 +165,14 @@ modalCell content = cell $ modal (toWidget $ hasComment True) (Right $ toWidget -- | Show Text if it is small, create modal otherwise modalCellLarge :: (IsDBTable m a, ToWidget UniWorX t, MonoFoldable t, Element t ~ Char) => t -> DBCell m a -modalCellLarge content +modalCellLarge content | length content > 32 = modalCell content | otherwise = stringCell content markupCellLargeModal :: IsDBTable m a => StoredMarkup -> DBCell m a markupCellLargeModal mup | markupIsSmallish mup = cell $ toWidget mup - | otherwise = modalCell mup + | otherwise = modalCell mup ----------------- -- Datatype cells @@ -221,44 +228,44 @@ cellHasUserLink toLink user = -- | like `cellHasUserLink` but opens the user in a modal instead; link is only displayed if the user has sufficient rights cellHasUserModal :: (IsDBTable m c, HasEntity u User) => (CryptoUUIDUser -> Route UniWorX) -> u -> DBCell m c -cellHasUserModal toLink user = +cellHasUserModal toLink user = let userEntity = user ^. hasEntityUser uid = userEntity ^. _entityKey nWdgt = nameWidget (userEntity ^. _entityVal . _userDisplayName) (userEntity ^. _entityVal . _userSurname) - lWdgt = do + lWdgt = do uuid <- liftHandler $ encrypt uid - modalAccess nWdgt nWdgt False $ toLink uuid + modalAccess nWdgt nWdgt False $ toLink uuid in cell lWdgt -- | like `cellHasUserModal` but but always display link without prior access rights checks cellHasUserModalAdmin :: (IsDBTable m c, HasEntity u User) => (CryptoUUIDUser -> Route UniWorX) -> u -> DBCell m c -cellHasUserModalAdmin toLink user = +cellHasUserModalAdmin toLink user = let userEntity = user ^. hasEntityUser uid = userEntity ^. _entityKey nWdgt = nameWidget (userEntity ^. _entityVal . _userDisplayName) (userEntity ^. _entityVal . _userSurname) - lWdgt = do + lWdgt = do uuid <- liftHandler $ encrypt uid - modal nWdgt $ Left $ SomeRoute $ toLink uuid + modal nWdgt $ Left $ SomeRoute $ toLink uuid in cell lWdgt -- | like `cellHasUserModal` but with fixed route and showing an edit icon instead; link is only displayed if the user has sufficient rights cellEditUserModal :: (IsDBTable m c, HasEntity u User) => u -> DBCell m c -cellEditUserModal user = +cellEditUserModal user = let userEntity = user ^. hasEntityUser uid = userEntity ^. _entityKey - nWdgt = toWidget $ icon IconUserEdit - lWdgt = do + nWdgt = toWidget $ icon IconUserEdit + lWdgt = do uuid <- liftHandler $ encrypt uid modalAccess mempty nWdgt True $ ForProfileR uuid in cell lWdgt -- | like `cellEditUserModal` but always displays the link without prior access rights checks cellEditUserModalAdmin :: (IsDBTable m c, HasEntity u User) => u -> DBCell m c -cellEditUserModalAdmin user = +cellEditUserModalAdmin user = let userEntity = user ^. hasEntityUser uid = userEntity ^. _entityKey - nWdgt = toWidget $ icon IconUserEdit - lWdgt = do + nWdgt = toWidget $ icon IconUserEdit + lWdgt = do uuid <- liftHandler $ encrypt uid modal nWdgt (Left $ SomeRoute $ ForProfileR uuid) in cell lWdgt @@ -267,23 +274,23 @@ cellHasMatrikelnummer :: (IsDBTable m a, HasUser u) => u -> DBCell m a cellHasMatrikelnummer = maybe mempty textCell . view _userMatrikelnummer cellHasMatrikelnummerLinked :: (IsDBTable m a, HasEntity u User) => Bool -> u -> DBCell m a -cellHasMatrikelnummerLinked isAdmin usr - | Just matNr <- usrEntity ^. _userMatrikelnummer = cell $ do +cellHasMatrikelnummerLinked isAdmin usr + | Just matNr <- usrEntity ^. _userMatrikelnummer = cell $ do uuid <- liftHandler $ encrypt $ usrEntity ^. _entityKey if isAdmin then modal (text2widget matNr) (Left $ SomeRoute $ AdminAvsUserR uuid) else modalAccess mempty (text2widget matNr) False (AdminAvsUserR uuid) | otherwise = mempty - where + where usrEntity = usr ^. hasEntityUser cellHasMatrikelnummerLinkedAdmin :: (IsDBTable m a, HasEntity u User) => u -> DBCell m a -cellHasMatrikelnummerLinkedAdmin usr - | Just matNr <- usrEntity ^. _userMatrikelnummer = cell $ do +cellHasMatrikelnummerLinkedAdmin usr + | Just matNr <- usrEntity ^. _userMatrikelnummer = cell $ do uuid <- liftHandler $ encrypt $ usrEntity ^. _entityKey - modal (text2widget matNr) (Left $ SomeRoute $ AdminAvsUserR uuid) + modal (text2widget matNr) (Left $ SomeRoute $ AdminAvsUserR uuid) | otherwise = mempty - where + where usrEntity = usr ^. hasEntityUser @@ -393,7 +400,7 @@ qualificationDescrCell (view hasQualification -> q@Qualification{..}) = qualific qualificationValidIconCell :: (IsDBTable m c, HasQualificationUser a, HasQualificationUserBlock b) => Day -> Maybe b -> a -> DBCell m c qualificationValidIconCell d qb qu = do blockIcon $ isValidQualification d qu qb - where + where blockIcon = cell . toWidget . iconQualificationBlock qualificationValidUntilCell :: (IsDBTable m c, HasQualificationUser a, HasQualificationUserBlock b) => Day -> Maybe b -> a -> DBCell m c @@ -402,11 +409,11 @@ qualificationValidUntilCell = qualificationValidUntilCell' (Just LmsUserAllR) qualificationValidUntilCell' :: (IsDBTable m c, HasQualificationUser a, HasQualificationUserBlock b) => Maybe (CryptoUUIDUser -> Route UniWorX) -> Day -> Maybe b -> a -> DBCell m c qualificationValidUntilCell' mbToLink d qb qu = cell $ case mbToLink of Nothing -> headWgt <> dateWgt - Just toLink -> do + Just toLink -> do uuid <- liftHandler $ encrypt $ qu ^. hasQualificationUser . _qualificationUserUser let modalWgt = modalAccess dateWgt dateWgt False $ toLink uuid headWgt <> modalWgt - where + where dateWgt = formatTimeW SelFormatDate (qu ^. hasQualificationUser . _qualificationUserValidUntil) iconWgt = toWidget $ iconQualificationBlock $ isValidQualification d qu qb headWgt = iconWgt <> [whamlet| |] @@ -416,18 +423,18 @@ qualificationValidReasonCell = qualificationValidReasonCell' (Just LmsUserAllR) qualificationValidReasonCell' :: (IsDBTable m c, HasQualificationUser a, HasQualificationUserBlock b) => Maybe (CryptoUUIDUser -> Route UniWorX) -> Bool -> Day -> Maybe b -> a -> DBCell m c qualificationValidReasonCell' mbToLink showReason d qb qu = ic <> foldMap blc qb - where + where ic = cell . toWidget . iconQualificationBlock $ isValidQualification d qu qb blc (view hasQualificationUserBlock -> QualificationUserBlock{..}) - | showReason = spacerCell <> dc qualificationUserBlockFrom <> spacerCell <> modalCellLarge qualificationUserBlockReason + | showReason = spacerCell <> dc qualificationUserBlockFrom <> spacerCell <> modalCellLarge qualificationUserBlockReason | qualificationUserBlockUnblock = mempty | otherwise = spacerCell <> dateCell qualificationUserBlockFrom - dc tstamp + dc tstamp | Just toLink <- mbToLink = cell $ do uuid <- liftHandler $ encrypt uid let dWgt = formatTimeW SelFormatDate tstamp modalAccess dWgt dWgt False $ toLink uuid - -- anchorCellM (toLink <$> encrypt uid) + -- anchorCellM (toLink <$> encrypt uid) | otherwise = dateCell tstamp uid = qu ^. hasQualificationUser . _qualificationUserUser @@ -438,15 +445,15 @@ qualificationValidReasonCell'' mbToLink showReason d qb qu extValid = ic <> icEr icErr = cell . toWidget . isBad $ quValid /= extValid ic = cell . toWidget $ iconQualificationBlock quValid blc (view hasQualificationUserBlock -> QualificationUserBlock{..}) - | showReason = spacerCell <> dc qualificationUserBlockFrom <> spacerCell <> modalCellLarge qualificationUserBlockReason + | showReason = spacerCell <> dc qualificationUserBlockFrom <> spacerCell <> modalCellLarge qualificationUserBlockReason | qualificationUserBlockUnblock = mempty | otherwise = spacerCell <> dateCell qualificationUserBlockFrom - dc tstamp + dc tstamp | Just toLink <- mbToLink = cell $ do uuid <- liftHandler $ encrypt uid let dWgt = formatTimeW SelFormatDate tstamp modalAccess dWgt dWgt False $ toLink uuid - -- anchorCellM (toLink <$> encrypt uid) + -- anchorCellM (toLink <$> encrypt uid) | otherwise = dateCell tstamp uid = qu ^. hasQualificationUser . _qualificationUserUser @@ -496,7 +503,7 @@ lmsStatusCell extendedInfo mkLink = wgtCell . lmsUserStatusWidget extendedInfo m lmsStateCell :: IsDBTable m a => LmsState -> DBCell m a lmsStateCell LmsFailed = iconBoolCell False -lmsStateCell LmsOpen = iconSpacerCell +lmsStateCell LmsOpen = iconSpacerCell lmsStateCell LmsPassed = iconBoolCell True avsPersonNoCell :: (IsDBTable m c, HasUserAvs a) => a -> DBCell m c @@ -515,7 +522,7 @@ avsPersonNoLinkedCellAdmin a = cell $ do modal nWgt (Left $ SomeRoute $ AdminAvsUserR uuid) avsPersonCardCell :: (IsDBTable m c) => Set AvsDataPersonCard -> DBCell m c -avsPersonCardCell cards = wgtCell +avsPersonCardCell cards = wgtCell [whamlet| $newline never