fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

chore(profile): towards #169

Browse Source 
- distinguished reroute icon
- profile cleaned/reordered
This commit is contained in:
Steffen Jost 2024-07-01 16:24:38 +02:00
parent d4f3ce7bf3
commit 6d49ea092b
8 changed files with 187 additions and 194 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
messages/uniworx/categories/settings/personal_settings/de-de-formal.msg
View File

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

3
messages/uniworx/categories/settings/personal_settings/en-eu.msg
View File

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

170
src/Handler/Profile.hs
View File

@ -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|
-- <div .container>
-- _{nodata}
-- |]
-- maybeTable' hdr _ mbRemark (True ,tbl) =
maybeTable' hdr _ mbRemark (_ ,tbl) =
[whamlet|
<div .container>
<h2> _{hdr}
<div .container>
^{tbl}
$maybe remark <- mbRemark
<em>_{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

56
src/Handler/Users.hs
View File

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

54
src/Handler/Utils/Table/Pagination.hs
View File

@ -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}|])

4
src/Utils.hs
View File

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

15
src/Utils/Icon.hs
View File

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

76
templates/profileData.hamlet
View File

@ -114,18 +114,6 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
_{MsgCompany}
<dd .deflist__dd>
^{compWgt}
$if numSupervisors > 0
<dt .deflist__dt>_{MsgProfileSupervisor}
$if numSupervisors > 3
\ #{numSupervisors}
<dd .deflist__dd>
^{mconcat supervisors}
$if numSupervisees > 0
<dt .deflist__dt>_{MsgProfileSupervisee}
$if length supervisees > 3
\ #{numSupervisees}
<dd .deflist__dd>
^{mconcat supervisees}
$if showAdminInfo
<dt .deflist__dt>
_{MsgUserCreated}
@ -197,67 +185,25 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
$nothing
^{formatTimeW SelFormatDateTime studyFeaturesLastObserved}
<section>
<div .container>
$if hasRowsOwnedCourses
<div .container>
<h2>_{MsgProfileCourses}
<div .container>
^{ownedCoursesTable}
<div .container>
<h2>_{MsgProfileCourseParticipations}
<div .container>
^{enrolledCoursesTable}
^{maybeTable' MsgProfileSupervisor (Just MsgProfileNoSupervisor) Nothing supervisorsTable}
^{maybeTable' MsgProfileSupervisee (Just MsgProfileNoSupervisee) (Just (msg2widget MsgProfileSuperviseeReroute <> toWgt (iconLetterOrEmail userPrefersPostal))) superviseesTable}
<div .container>
<h2>_{MsgProfileQualifications}
<div .container>
^{qualificationsTable}
<div .container>
<h2>_{MsgProfileCourseExamResults}
<div .container>
^{examTable}
^{maybeTable MsgProfileCourses ownedCoursesTable}
^{maybeTable MsgProfileCourseParticipations enrolledCoursesTable}
<div .container>
<h2>_{MsgProfileTutorials}
<div .container>
^{ownTutorialTable}
^{maybeTable MsgProfileSubmissionGroups submissionGroupTable}
<div .container>
<h2>_{MsgProfileTutorialParticipations}
<div .container>
^{tutorialTable}
<div .container>
<h2>_{MsgProfileSubmissionGroups}
<div .container>
^{submissionGroupTable}
<div .container>
<h2>_{MsgProfileSubmissions}
<div .container>
^{submissionTable}
<em>_{MsgProfileRemark}
\ _{MsgProfileGroupSubmissionDates}
<div .container>
<h2> _{MsgTableCorrector}
<div .container>
^{correctionsTable}
<em>_{MsgProfileRemark}
\ _{MsgProfileCorrectorRemark}
<a href=@{CorrectionsR}>_{MsgProfileCorrections}
<div .container>
<h2> _{MsgProfileSupervisor}
<div .container>
^{supervisorsTable}
<div .container>
<h2> _{MsgProfileSupervisee}
<div .container>
^{superviseesTable}
^{maybeTable' MsgProfileSubmissions Nothing (Just (msg2widget MsgProfileGroupSubmissionDates)) submissionTable}
^{maybeTable' MsgTableCorrector Nothing (Just (msg2widget MsgProfileCorrectorRemark <> simpleLinkI MsgProfileCorrections CorrectionsR)) correctionsTable}
^{profileRemarks}