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} -