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

Merge branch 'fradrive/newletter'

Browse Source
This commit is contained in:
Steffen Jost 2024-07-02 18:16:48 +02:00
commit 9e2a964ef7
25 changed files with 585 additions and 517 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
messages/uniworx/categories/avs/de-de-formal.msg
View File

@ -4,7 +4,9 @@
AvsPersonInfo: AVS Personendaten
AvsPersonId: AVS Personen Id
AvsPersonNo: AVS Personennummer
AvsPersonNoNotId: AVS Personennummer dient zur menschlichen Kommunikation mit der Ausweisstelle und darf nicht verwechselt werden mit der maschinell verwendeten AVS Personen Id
AvsPersonNoMismatch: AVS Personennummer hat sich geändert und wurde in FRADrive noch nicht aktualisiert
AvsPersonNoDiffers: Es sind derzeit zwei verschiedene AVS Personennummern zugeordnet. Bitte einen Administrator kontaktieren.
AvsCardNo: Ausweiskartennummer
AvsFirstName: Vorname
AvsLastName: Nachname
@ -15,7 +17,6 @@ AvsQueryNeeded: Benötigt Verbindung zum AVS.
AvsQueryEmpty: Bitte mindestens ein Anfragefeld ausfüllen!
AvsQueryStatusInvalid t@Text: Nur numerische IDs eingeben, durch Komma getrennt! Erhalten: #{show t}
AvsLicence: Fahrberechtigung
AvsPersonNoNotId: AVS Personennummer dient zur menschlichen Kommunikation mit der Ausweisstelle und darf nicht verwechselt werden mit der maschinell verwendeten AVS Personen Id
AvsTitleLicenceSynch: Abgleich Fahrberechtigungen zwischen AVS und FRADrive
BtnAvsRevokeUnknown: Fahrberechtigungen im AVS sofort entziehen
BtnAvsImportUnknown: AVS Daten unbekannter Personen importieren
@ -45,6 +46,7 @@ AvsCardColorBlue: Blau
AvsCardColorRed: Rot
AvsCardColorYellow: Gelb
LastAvsSynchronisation: Letzte AVS-Synchronisation
LastAvsSyncedBefore: Letzte AVS-Synchronisation vor
LastAvsSynchError: Letzte AVS-Fehlermeldung
AvsInterfaceUnavailable: AVS Schnittstelle nicht richtig konfiguriert oder antwortet nicht

5
messages/uniworx/categories/avs/en-eu.msg
View File

@ -4,7 +4,9 @@
AvsPersonInfo: AVS person info
AvsPersonId: AVS person id
AvsPersonNo: AVS person number
AvsPersonNoNotId: AVS person number is used in human communication only and must not be mistaken for the AVS personen id used in machine communications
AvsPersonNoMismatch: AVS person number has changed and was not yet updated in FRADrive
AvsPersonNoDiffers: There are currently two differing AVS person numbers associated with this user. Please contact an administrator to resolve this.
AvsCardNo: Card number
AvsFirstName: First name
AvsLastName: Last name
@ -15,7 +17,7 @@ AvsQueryNeeded: AVS connection required.
AvsQueryEmpty: At least one query field must be filled!
AvsQueryStatusInvalid t: Numeric IDs only, comma seperated! #{show t}
AvsLicence: Driving Licence
AvsPersonNoNotId: AVS person number is used in human communication only and must not be mistaken for the AVS personen id used in machine communications
AvsTitleLicenceSynch: Synchronisation driving licences between AVS and FRADrive
BtnAvsRevokeUnknown: Revoke AVS driving licences for unknown persons immediately
BtnAvsImportUnknown: Import AVS data for unknown persons
@ -45,6 +47,7 @@ AvsCardColorBlue: Blue
AvsCardColorRed: Red
AvsCardColorYellow: Yellow
LastAvsSynchronisation: Last AVS synchronisation
LastAvsSyncedBefore: Last AVS synchronisation before
LastAvsSynchError: Last AVS Error
AvsInterfaceUnavailable: AVS interface was not configured correctly or does not respond

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

@ -25,10 +25,14 @@ PersonalInfoTutorialsWip: Die Anzeige von Kurse, zu denen Sie angemeldet sind wi
ProfileGroupSubmissionDates: Bei Gruppenabgaben wird kein Datum angezeigt, wenn Sie die Gruppenabgabe nie selbst hochgeladen haben.
ProfileCorrectorRemark: Die oberhalb angezeigte Tabelle zeigt nur prinzipielle Einteilungen als Korrektor zu einem Übungsblatt. Auch ohne Einteilung können Korrekturen einzeln zugewiesen werden, welche hier dann nicht aufgeführt werden.
ProfileCorrections: Auflistung aller zugewiesenen Korrekturen
Remarks: Hinweise
Remarks: Hinweis:
ProfileSupervisor: Übergeordnete Ansprechpartner
ProfileSupervisee: Ist Ansprechpartner für
ProfileNoSupervisor: Keine übergeordneten Ansprechpartner vorhanden
ProfileSupervisor n@Int m@Int: #{n} #{pluralDE n "übergeordneter" "übergeordnete"} Ansprechpartner#{noneMoreDE m "" (", davon " <> tshow m <> " mit Benachrichtigungsumleitung")}
ProfileSupervisorRemark n@Int m@Int l@Int: #{m}/#{n} #{pluralDE m "übergeordneter" "übergeordnete"} Ansprechpartner mit Benachrichtigungsumleitung#{noneMoreDE l "" (", davon " <> tshow l <> " mit postalischer Benachrichtigung")}
ProfileNoSupervisee: Ist kein Ansprechpartner für irgendjemand
ProfileSupervisee n@Int m@Int: Ist Ansprechpartner für #{n} #{pluralDE n "Person" "Personen"}#{noneMoreDE m "" (", davon " <> tshow m <> " mit Benachrichtigungsumleitung")}
ProfileSuperviseeRemark n@Int m@Int: Dieser Nutzer ist Ansprechpartner für #{n} #{pluralDE n "Person" "Personen"}#{noneMoreDE m "" (", davon " <> tshow m <> " mit Benachrichtigungsumleitung")}
UserTelephone: Telefon
UserMobile: Mobiltelefon

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

@ -25,10 +25,14 @@ PersonalInfoTutorialsWip: The feature to display courses you have registered for
ProfileGroupSubmissionDates: No date is shown for group submissions if you have never uploaded the submission yourself.
ProfileCorrectorRemark: The table above only shows registration as a corrector in principle. Even without registration corrections can be assigned individually and are not listed.
ProfileCorrections: List of all assigned corrections
Remarks: Remarks
Remarks: Remark:
ProfileSupervisor: Supervised by
ProfileSupervisee: Supervises
ProfileNoSupervisor: Is not supervised by anynone
ProfileSupervisor n m: #{pluralENsN n "supervisor"} #{noneMoreEN m "" ("with " <> tshow m <> " active notification rerouting")}
ProfileSupervisorRemark n@Int m@Int l@Int: #{m}/#{n} #{pluralENs m "supervisor"} with active notification rerouting#{noneMoreEN l "" (", and " <> tshow l <> "of these prefer postal notifications")}
ProfileNoSupervisee: Does not supervise anynone
ProfileSupervisee n m: Supervises #{pluralENsN n "person"} #{noneMoreEN m "" ("with " <> tshow m <> " active notification rerouting")}
ProfileSuperviseeRemark n m: This person supervises #{pluralENsN n "person"}#{noneMoreEN m "" (" with " <> tshow m <> " having active notifications rerouting to this user")}
UserTelephone: Phone
UserMobile: Mobile

37
src/Foundation/I18n.hs
View File

@ -88,15 +88,14 @@ pluralDE num singularForm pluralForm
| otherwise = pluralForm
pluralDEx :: (Eq a, Num a) => Char -> a -> Text -> Text
-- ^ @pluralENs n "Monat" = pluralEN n "Monat" "Monate"@
pluralDEx c n t = pluralDE n t $ t `snoc` c
-- | like `pluralDEe` but also prefixes with the number
-- | like `pluralDEx` but also prefixes with the number
pluralDExN :: (Eq a, Num a, Show a) => Char -> a -> Text -> Text
pluralDExN c n t = tshow n <> cons ' ' (pluralDEx c n t)
pluralDEe :: (Eq a, Num a) => a -> Text -> Text
-- ^ @pluralENs n "Monat" = pluralEN n "Monat" "Monate"@
-- ^ @pluralDEe n "Monat" = pluralDEe n "Monat" "Monate"@
pluralDEe = pluralDEx 'e'
-- | like `pluralDEe` but also prefixes with the number
@ -124,14 +123,14 @@ noneOneMoreDE num noneText singularForm pluralForm
| num == 1 = singularForm
| otherwise = pluralForm
-- noneMoreDE :: (Eq a, Num a)
-- => a -- ^ Count
-- -> Text -- ^ None
-- -> Text -- ^ Some
-- -> Text
-- noneMoreDE num noneText someText
-- | num == 0 = noneText
-- | otherwise = someText
noneMoreDE :: (Eq a, Num a)
=> a -- ^ Count
-> Text -- ^ None
-> Text -- ^ Some
-> Text
noneMoreDE num noneText someText
| num == 0 = noneText
| otherwise = someText
pluralEN :: (Eq a, Num a)
=> a -- ^ Count
@ -164,14 +163,14 @@ noneOneMoreEN num noneText singularForm pluralForm
| num == 1 = singularForm
| otherwise = pluralForm
-- noneMoreEN :: (Eq a, Num a)
-- => a -- ^ Count
-- -> Text -- ^ None
-- -> Text -- ^ Some
-- -> Text
-- noneMoreEN num noneText someText
-- | num == 0 = noneText
-- | otherwise = someText
noneMoreEN :: (Eq a, Num a)
=> a -- ^ Count
-> Text -- ^ None
-> Text -- ^ Some
-> Text
noneMoreEN num noneText someText
| num == 0 = noneText
| otherwise = someText
_ordinalEN :: ToMessage a
=> a

7
src/Handler/Admin/Avs.hs
View File

@ -560,7 +560,7 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do
, sortable (Just "avspersonno") (i18nCell MsgAvsPersonNo) $ \(view resultUserAvs -> a) -> avsPersonNoLinkedCellAdmin a
-- , colUserCompany
, sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \(view (resultUser . _entityKey) -> uid) -> flip (set' cellContents) mempty $ do -- why does sqlCell not work here? Mismatch "YesodDB UniWorX" and "RWST (Maybe (Env,FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX"
companies' <- liftHandler . runDB . E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
companies' <- liftHandler . runDBRead . E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid
E.orderBy [E.asc (comp E.^. CompanyName)]
@ -639,8 +639,8 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do
mkOption :: E.Value Text -> Option Text
mkOption (E.unValue -> t) = Option{ optionDisplay = t, optionInternalValue = t, optionExternalValue = toPathPiece t }
suggestionsBlock :: HandlerFor UniWorX (OptionList Text)
suggestionsBlock = mkOptionList . fmap mkOption <$> runDB (getBlockReasons E.not_)
suggestionsUnblock = mkOptionList . fmap mkOption <$> runDB (getBlockReasons id)
suggestionsBlock = mkOptionList . fmap mkOption <$> runDBRead (getBlockReasons E.not_)
suggestionsUnblock = mkOptionList . fmap mkOption <$> runDBRead (getBlockReasons id)
acts :: Map LicenceTableAction (AForm Handler LicenceTableActionData)
acts = mconcat
@ -949,4 +949,3 @@ getProblemAvsErrorR = do
siteLayoutMsg MsgMenuAvsSynchError $ do
setTitleI MsgMenuAvsSynchError
[whamlet|^{avsSyncErrTbl}|]

2
src/Handler/Course/Register.hs
View File

@ -68,7 +68,7 @@ courseRegisterForm (Entity cid Course{..}) = liftHandler $ do
| otherwise
-> return $ FormSuccess ()
mayViewCourseAfterDeregistration <- liftHandler . runDB $ E.selectExists . E.from $ \course -> do
mayViewCourseAfterDeregistration <- liftHandler . runDBRead $ E.selectExists . E.from $ \course -> do
E.where_ $ course E.^. CourseId E.==. E.val cid
E.&&. ( isSchoolAdminLike muid ata (course E.^. CourseSchool)
E.||. mayEditCourse muid ata course

39
src/Handler/Firm.hs
View File

@ -119,7 +119,7 @@ firmActionHandler route isAdmin = flip formResult faHandler
faHandler (_,fids) | null fids = addMessageI Error MsgNoCompanySelected
faHandler (FirmActNotifyData, Set.toList -> fids) = do
usrs <- runDB $ E.select $ E.distinct $ do
usrs <- runDBRead $ E.select $ E.distinct $ do
(usr :& uc) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(emp :& uc) -> emp E.^. UserId E.==. uc E.^. UserCompanyUser)
E.where_ $ uc E.^. UserCompanyCompany `E.in_` E.valList fids
return $ usr E.^. UserId
@ -325,34 +325,33 @@ addDefaultSupervisorsAll mutualSupervision cids = do
------------------------------
-- repeatedly useful queries
usrSuperiorCompanies :: E.SqlExpr (Entity Company) -> E.SqlExpr (Entity UserCompany) -> E.SqlQuery ()
-- usrSuperiorCompanies :: E.SqlExpr (E.Value CompanyId) -> E.SqlExpr (Entity UserCompany) -> E.SqlQuery (Entity UserCompany) -- possible alternative
usrSuperiorCompanies cmp usr = do
othr <- E.from $ E.table @UserCompany
E.where_ $ othr E.^. UserCompanyPriority E.>. usr E.^. UserCompanyPriority
E.&&. othr E.^. UserCompanyUser E.==. usr E.^. UserCompanyUser
E.&&. othr E.^. UserCompanyCompany E.!=. cmp E.^. CompanyId -- redundant due to > above, but likely performance improving
-- return othr
fromUserCompany :: Maybe (E.SqlExpr (Entity UserCompany) -> E.SqlExpr (E.Value Bool)) -> E.SqlExpr (Entity Company) -> E.SqlQuery ()
fromUserCompany mbFltr cmpy = do
usrCmpy <- E.from $ E.table @UserCompany
let basecond = usrCmpy E.^. UserCompanyCompany E.==. cmpy E.^. CompanyId
E.where_ $ maybe basecond ((basecond E.&&.).($ usrCmpy)) mbFltr
firmCountUsers :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
firmCountUsers = E.subSelectCount . fromUserCompany Nothing
firmCountUsers :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
firmCountUsers = E.subSelectCount . fromUserCompany Nothing
firmCountUsersPrimary :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
firmCountUsersPrimary cmp = E.subSelectCount $ fromUserCompany (Just primFltr) cmp
firmCountUsersPrimary :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
firmCountUsersPrimary cmp = E.subSelectCount $ fromUserCompany (Just primFltr) cmp
where
primFltr usr = E.notExists (do
othr <- E.from $ E.table @UserCompany
E.where_ $ othr E.^. UserCompanyPriority E.>. usr E.^. UserCompanyPriority
E.&&. othr E.^. UserCompanyUser E.==. usr E.^. UserCompanyUser
E.&&. othr E.^. UserCompanyCompany E.!=. cmp E.^. CompanyId -- redundant due to > above, but likely performance improving
)
primFltr = E.notExists . usrSuperiorCompanies cmp
firmCountUsersSecondary :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
firmCountUsersSecondary :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
firmCountUsersSecondary cmp = E.subSelectCount $ fromUserCompany (Just primFltr) cmp
where
primFltr usr = E.exists (do
othr <- E.from $ E.table @UserCompany
E.where_ $ othr E.^. UserCompanyPriority E.>. usr E.^. UserCompanyPriority
E.&&. othr E.^. UserCompanyUser E.==. usr E.^. UserCompanyUser
E.&&. othr E.^. UserCompanyCompany E.!=. cmp E.^. CompanyId -- redundant due to > above, but likely performance improving
)
primFltr = E.exists . usrSuperiorCompanies cmp
firmCountSupervisors :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
firmCountSupervisors = E.subSelectCount . fromUserCompany (Just (E.^. UserCompanySupervisor))
@ -1375,14 +1374,14 @@ handleFirmCommR ultDest cs = do
csKeys = CompanyKey <$> cs
mbUser <- maybeAuthId
-- get employees of chosen companies
empys <- mkCompanyUsrList <$> runDB (E.select $ do
empys <- mkCompanyUsrList <$> runDBRead (E.select $ do
(emp :& cmp) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(emp :& cmp) -> emp E.^. UserId E.==. cmp E.^. UserCompanyUser)
E.where_ $ cmp E.^. UserCompanyCompany `E.in_` E.valList csKeys
E.orderBy [E.ascNullsFirst $ cmp E.^. UserCompanyCompany]
return (E.just $ cmp E.^. UserCompanyCompany, emp E.^. UserId)
)
-- get supervisors of employees
sprs <- mkCompanyUsrList <$> runDB (E.select $ do
sprs <- mkCompanyUsrList <$> runDBRead (E.select $ do
(spr :& cmp) <- E.from $ E.table @User `E.leftJoin` E.table @UserCompany `E.on` (\(spr :& cmp) -> spr E.^. UserId E.=?. cmp E.?. UserCompanyUser)
E.where_ $ (E.isTrue (cmp E.?. UserCompanySupervisor) E.&&. cmp E.?. UserCompanyCompany `E.in_` E.justValList csKeys)
E.||. (spr E.^. UserId E.=?. E.val mbUser)

2
src/Handler/LMS.hs
View File

@ -792,7 +792,7 @@ viewLmsUserR :: Maybe SchoolId -> Maybe QualificationShorthand -> CryptoUUIDUser
viewLmsUserR msid mqsh uuid = do
uid <- decrypt uuid
now <- liftIO getCurrentTime
(user@User{userDisplayName}, quals, qblocks) <- runDB $ do
(user@User{userDisplayName}, quals, qblocks) <- runDBRead $ do
usr <- get404 uid
qs <- Ex.select $ do
(qual :& qualUsr :& lmsUsr) <-

20
src/Handler/News.hs
View File

@ -315,16 +315,16 @@ newsUpcomingExams uid = do
| otherwise -> mempty
]
dbtSorting = Map.fromList
[ ("demo-both", SortColumn $ queryCourse &&& queryExam >>> (\(_course,exam)-> exam E.^. ExamName))
, ("term", SortColumn $ queryCourse >>> (E.^. CourseTerm ))
, ("school", SortColumn $ queryCourse >>> (E.^. CourseSchool ))
, ("course", SortColumn $ queryCourse >>> (E.^. CourseShorthand ))
, ("name", SortColumn $ queryExam >>> (E.^. ExamName ))
, ("time", SortColumn $ queryExam >>> (E.^. ExamStart ))
, ("register-from", SortColumn $ queryExam >>> (E.^. ExamRegisterFrom ))
, ("register-to", SortColumn $ queryExam >>> (E.^. ExamRegisterTo ))
, ("visible", SortColumn $ queryExam >>> (E.^. ExamVisibleFrom ))
, ("registered", SortColumn $ queryExam >>> (\exam ->
[ ("demo-both", SortColumns $ queryCourse &&& queryExam >>> (\(course,exam)-> [SomeExprValue $ course E.^. CourseShorthand, SomeExprValue $ exam E.^. ExamName]))
, ("term", SortColumn $ queryCourse >>> (E.^. CourseTerm ))
, ("school", SortColumn $ queryCourse >>> (E.^. CourseSchool ))
, ("course", SortColumn $ queryCourse >>> (E.^. CourseShorthand ))
, ("name", SortColumn $ queryExam >>> (E.^. ExamName ))
, ("time", SortColumn $ queryExam >>> (E.^. ExamStart ))
, ("register-from", SortColumn $ queryExam >>> (E.^. ExamRegisterFrom ))
, ("register-to", SortColumn $ queryExam >>> (E.^. ExamRegisterTo ))
, ("visible", SortColumn $ queryExam >>> (E.^. ExamVisibleFrom ))
, ("registered", SortColumn $ queryExam >>> (\exam ->
E.exists $ E.from $ \registration -> do
E.where_ $ registration E.^. ExamRegistrationUser E.==. E.val uid
E.where_ $ registration E.^. ExamRegistrationExam E.==. exam E.^. ExamId

166
src/Handler/Profile.hs
View File

@ -156,7 +156,7 @@ schoolsForm template = formToAForm $ schoolsFormView =<< renderWForm FormStandar
where
schoolsForm' :: WForm Handler (FormResult (Set SchoolId))
schoolsForm' = do
allSchools <- liftHandler . runDB $ selectList [] [Asc SchoolName]
allSchools <- liftHandler . runDBRead $ selectList [] [Asc SchoolName]
let
schoolForm (Entity ssh School{schoolName})
@ -585,6 +585,41 @@ getForProfileDataR cID = 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) =
[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
@ -605,42 +640,51 @@ makeProfileData usrEnt@(Entity uid usrVal@User{..}) = do
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
correctionsTable <- mkCorrectionsTable uid -- Tabelle mit allen Korrektor-Aufgaben
qualificationsTable <- mkQualificationsTable now uid -- Tabelle mit allen Qualifikationen
supervisorsTable <- mkSupervisorsTable uid -- Tabelle mit allen Supervisors
superviseesTable <- mkSuperviseesTable uid -- Tabelle mit allen Supervisees
let examTable, ownTutorialTable, tutorialTable :: Widget
examTable = i18n MsgPersonalInfoExamAchievementsWip
ownTutorialTable = i18n MsgPersonalInfoOwnTutorialsWip
tutorialTable = i18n MsgPersonalInfoTutorialsWip
superviseesTable <- mkSuperviseesTable actualPrefersPostal uid -- Tabelle mit allen Supervisees
let supervisorsWgt :: Widget =
let ((getSum -> nrSupers, getSum -> nrReroute, getSum -> nrLetter), tWgt) = supervisorsTable
in maybeTable' (MsgProfileSupervisor nrSupers nrReroute) (Just MsgProfileNoSupervisor)
(toMaybe (nrReroute > 0) $ msg2widget $ MsgProfileSupervisorRemark nrSupers nrReroute nrLetter) (nrSupers > 0, tWgt)
superviseesWgt :: Widget =
let ((getSum -> nrSubs, getSum -> nrReroute), tWgt) = superviseesTable
in maybeTable' (MsgProfileSupervisee nrSubs nrReroute) (Just MsgProfileNoSupervisee)
(toMaybe (nrReroute > 0) $ msg2widget $ MsgProfileSuperviseeRemark nrSubs nrReroute) (nrSubs > 0, tWgt)
-- let examTable, ownTutorialTable, tutorialTable :: Widget
-- examTable = i18n MsgPersonalInfoExamAchievementsWip
-- ownTutorialTable = i18n MsgPersonalInfoOwnTutorialsWip
-- tutorialTable = i18n MsgPersonalInfoTutorialsWip
cID <- encrypt uid
mCRoute <- getCurrentRoute
showAdminInfo <- pure (mCRoute == Just (AdminUserR cID)) `or2M` hasReadAccessTo (AdminUserR cID)
tooltipAvsPersNo <- messageI Info MsgAvsPersonNoNotId
tooltipInvalidEmail <- messageI Error MsgInvalidEmailAddress
tooltipAvsPersNo <- messageI Info MsgAvsPersonNoNotId
tooltipAvsPersNoDiffers <- messageI Error MsgAvsPersonNoDiffers
tooltipInvalidEmail <- messageI Error MsgInvalidEmailAddress
let profileRemarks = $(i18nWidgetFile "profile-remarks")
return $(widgetFile "profileData")
@ -698,7 +742,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 +750,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
@ -717,7 +761,7 @@ mkEnrolledCoursesTable =
, dbtRowKey = \(course `E.InnerJoin` _) -> course E.^. CourseId
, dbtProj = dbtProjId <&> _dbrOutput . _2 %~ E.unValue
, dbtColonnade = mconcat
[ sortable (Just "term") (i18nCell MsgTableTerm) $
[ sortable (Just "term") (i18nCell MsgTableTerm) $ fmap addIndicatorCell
termCell <$> view (_dbrOutput . _1 . _entityVal . _courseTerm)
, sortable (Just "school") (i18nCell MsgTableCourseSchool) . magnify (_dbrOutput . _1 . _entityVal) $
schoolCell <$> view _courseTerm
@ -750,7 +794,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
@ -784,7 +828,7 @@ mkSubmissionTable =
<&> _dbrOutput . _4 %~ E.unValue
dbtColonnade = mconcat
[ sortable (Just "term") (i18nCell MsgTableTerm) $
[ sortable (Just "term") (i18nCell MsgTableTerm) $ fmap addIndicatorCell
termCell <$> view (_dbrOutput . _1 . _1)
, sortable (Just "school") (i18nCell MsgTableCourseSchool) . magnify (_dbrOutput . _1 ) $
schoolCell <$> view _1
@ -828,14 +872,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
@ -858,7 +898,7 @@ mkSubmissionGroupTable =
<&> _dbrOutput . _1 %~ $(E.unValueN 3)
dbtColonnade = mconcat
[ sortable (Just "term") (i18nCell MsgTableTerm) $
[ sortable (Just "term") (i18nCell MsgTableTerm) $ fmap addIndicatorCell
termCell <$> view (_dbrOutput . _1 . _1)
, sortable (Just "school") (i18nCell MsgTableCourseSchool) . magnify (_dbrOutput . _1 ) $
schoolCell <$> view _1
@ -887,10 +927,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
@ -923,7 +963,7 @@ mkCorrectionsTable =
<&> _dbrOutput . _2 %~ E.unValue
dbtColonnade = mconcat
[ sortable (Just "term") (i18nCell MsgTableTerm) $
[ sortable (Just "term") (i18nCell MsgTableTerm) $ fmap addIndicatorCell
termCellCL <$> view (_dbrOutput . _1)
, sortable (Just "school") (i18nCell MsgTableCourseSchool) $
schoolCellCL <$> view (_dbrOutput . _1)
@ -960,7 +1000,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
@ -983,7 +1023,7 @@ mkQualificationsTable =
, dbtProj = dbtProjId
, dbtColonnade = mconcat
[ colSchool (_dbrOutput . _1 . _entityVal . _qualificationSchool)
, sortable (Just "quali") (i18nCell MsgQualificationName) $ qualificationDescrCell <$> view (_dbrOutput . _1 . _entityVal)
, sortable (Just "quali") (i18nCell MsgQualificationName) $ qualificationDescrCell <$> view (_dbrOutput . _1 . _entityVal)
, sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ dayCell <$> view (_dbrOutput . _2 . _entityVal . _qualificationUserFirstHeld )
, sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh) $ dayCell <$> view (_dbrOutput . _2 . _entityVal . _qualificationUserLastRefresh)
, sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) $ dayCell <$> view (_dbrOutput . _2 . _entityVal . _qualificationUserValidUntil )
@ -1027,8 +1067,8 @@ 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{..}
mkSupervisorsTable :: UserId -> DB ((Sum Int, Sum Int, Sum Int), Widget)
mkSupervisorsTable uid = dbTableWidget validator DBTable{..}
where
dbtIdent = "userSupervisedBy" :: Text
dbtStyle = def
@ -1043,8 +1083,15 @@ 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) -> indicatorCell <> ifIconCell b IconReroute
-- , sortable (Just "postal-pref") (i18nCell MsgPrefersPostal) $ \(view $ resultUser . _userPrefersPostal -> b) -> iconFixedCell $ iconLetterOrEmail b
, sortable (Just "reroute") (i18nCell MsgTableRerouteActive) $ \row ->
let isReroute = row ^. resultUserSupervisor . _entityVal ._userSupervisorRerouteNotifications
isLetter = row ^. resultUser . _userPrefersPostal
in tellCell (Sum 1, Sum $ fromEnum isReroute, Sum $ fromEnum $ isReroute && isLetter) $
if isReroute
then iconCell IconReroute <> spacerCell <> iconFixedCell (iconLetterOrEmail isLetter)
else mempty
, sortable (Just "cshort") (i18nCell MsgTableCompany) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorCompany -> mc) -> maybeCell mc (\(unCompanyKey -> c) -> anchorCell (FirmUsersR c) $ citext2widget c)
, sortable (Just "reason") (i18nCell MsgSupervisorReason) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorReason -> mr) -> maybeCell mr textCell
]
@ -1054,6 +1101,11 @@ mkSupervisorsTable uid = dbTableWidget' validator DBTable{..}
, singletonMap & uncurry $ sortUserEmail queryUser
, singletonMap "postal-pref" $ SortColumn $ queryUser >>> (E.^. UserPrefersPostal)
, singletonMap "rerouted" $ SortColumn $ queryUserSupervisor >>> (E.^. UserSupervisorRerouteNotifications)
-- , singletonMap "reroute" $ SortColumn $ queryUserSupervisor &&& queryUser >>> (\(spr,usr) -> mTuple (spr E.^. UserSupervisorRerouteNotifications) (usr E.^. UserPrefersPostal))
, singletonMap "reroute" $ SortColumns $ \row ->
[ SomeExprValue $ queryUserSupervisor row E.^. UserSupervisorRerouteNotifications
, SomeExprValue $ queryUser row E.^. UserPrefersPostal
]
, singletonMap "cshort" $ SortColumn $ queryUserSupervisor >>> (E.^. UserSupervisorCompany)
, singletonMap "reason" $ SortColumn $ queryUserSupervisor >>> (E.^. UserSupervisorReason)
]
@ -1068,8 +1120,8 @@ mkSupervisorsTable uid = dbTableWidget' validator DBTable{..}
-- | Table listing all persons supervised by the given user
mkSuperviseesTable :: UserId -> DB Widget
mkSuperviseesTable uid = dbTableWidget' validator DBTable{..}
mkSuperviseesTable ::Bool -> UserId -> DB ((Sum Int, Sum Int), Widget)
mkSuperviseesTable userPrefersPostal uid = dbTableWidget validator DBTable{..}
where
dbtIdent = "userSupervisedBy" :: Text
dbtStyle = def
@ -1081,11 +1133,15 @@ mkSuperviseesTable uid = dbTableWidget' validator DBTable{..}
dbtRowKey (_ `E.InnerJoin` spr) = spr E.^. UserSupervisorId
dbtProj = dbtProjId
iconCellLetterOrEmail = spacerCell <> iconFixedCell (iconLetterOrEmail userPrefersPostal) -- only notification type of supervisor matters here
dbtColonnade = mconcat
[ colUserNameModalHdr MsgTableSupervisee ForProfileDataR
-- , colUserEmail
, colUserEmail
-- , sortable (Just "rerouted") (i18nCell MsgTableRerouteActive) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorRerouteNotifications -> b) -> ifIconCell b IconReroute
-- , sortable (Just "postal-pref") (i18nCell MsgPrefersPostal) $ \(view $ resultUser . _userPrefersPostal -> b) -> iconFixedCell $ iconLetterOrEmail b
, sortable (Just "rerouted") (i18nCell MsgTableRerouteActive) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorRerouteNotifications -> b) -> tickmarkCell b
, sortable (Just "reroute") (i18nCell MsgTableRerouteActive) $ \row ->
let isReroute = row ^. resultUserSupervisor . _entityVal ._userSupervisorRerouteNotifications
in tellCell (Sum 1, Sum $ fromEnum isReroute) $ boolCell isReroute $ iconCell IconReroute <> iconCellLetterOrEmail
, sortable (Just "cshort") (i18nCell MsgTableCompany) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorCompany -> mc) -> maybeCell mc (\(unCompanyKey -> c) -> anchorCell (FirmUsersR c) $ citext2widget c)
, sortable (Just "reason") (i18nCell MsgSupervisorReason) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorReason -> mr) -> maybeCell mr textCell
]
@ -1093,8 +1149,12 @@ mkSuperviseesTable uid = dbTableWidget' validator DBTable{..}
dbtSorting = mconcat
[ singletonMap & uncurry $ sortUserNameLink queryUser
, singletonMap & uncurry $ sortUserEmail queryUser
, singletonMap "postal-pref" $ SortColumn $ queryUser >>> (E.^. UserPrefersPostal)
, singletonMap "rerouted" $ SortColumn $ queryUserSupervisor >>> (E.^. UserSupervisorRerouteNotifications)
-- , singletonMap "postal-pref" $ SortColumn $ queryUser >>> (E.^. UserPrefersPostal)
-- , singletonMap "rerouted" $ SortColumn $ queryUserSupervisor >>> (E.^. UserSupervisorRerouteNotifications)
, singletonMap "reroute" $ SortColumns $ \row ->
[ SomeExprValue $ queryUserSupervisor row E.^. UserSupervisorRerouteNotifications
, SomeExprValue $ queryUser row E.^. UserPrefersPostal
]
, singletonMap "cshort" $ SortColumn $ queryUserSupervisor >>> (E.^. UserSupervisorCompany)
, singletonMap "reason" $ SortColumn $ queryUserSupervisor >>> (E.^. UserSupervisorReason)
]

2
src/Handler/SAP.hs
View File

@ -98,7 +98,7 @@ getQualificationSAPDirectR = do
now <- liftIO getCurrentTime
fdate <- formatTime' "%Y%m%d_%H-%M" now
let ldap_cutoff = addDiffDaysRollOver (fromMonths $ -3) now
qualUsers <- runDB $ E.select $ do
qualUsers <- runDBRead $ E.select $ do
(qual :& qualUser :& user :& qualBlock) <-
E.from $ E.table @Qualification
`E.innerJoin` E.table @QualificationUser

15
src/Handler/Users.hs
View File

@ -121,21 +121,21 @@ postUsersR = do
-- (AdminUserR <$> encrypt uid)
-- (toWidget . display $ last $ impureNonNull $ words $ userDisplayName)
, sortable (Just "user-supervisor") (i18nCell MsgTableSupervisor) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do
supervisors' <- liftHandler . runDB . E.select $ E.from $ \(spvr `E.InnerJoin` usrSpvr) -> do
supervisors' <- liftHandler . runDBRead . 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 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 "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
schools <- liftHandler . runDB . E.select . E.from $ \(school `E.InnerJoin` userFunction) -> do
schools <- liftHandler . runDBRead . E.select . E.from $ \(school `E.InnerJoin` userFunction) -> do
E.on $ school E.^. SchoolId E.==. userFunction E.^. UserFunctionSchool
E.where_ $ userFunction E.^. UserFunctionUser E.==. E.val uid
E.&&. userFunction E.^. UserFunctionFunction E.==. E.val function
@ -148,7 +148,7 @@ postUsersR = do
<li>#{sh}
|]
, sortable (Just "system-function") (i18nCell MsgUserSystemFunctions) $ \DBRow{ dbrOutput = Entity uid _ } ->
let getFunctions = fmap (map $ userSystemFunctionFunction . entityVal) . liftHandler . runDB $ selectList [ UserSystemFunctionUser ==. uid, UserSystemFunctionIsOptOut ==. False ] [ Asc UserSystemFunctionFunction ]
let getFunctions = fmap (map $ userSystemFunctionFunction . entityVal) . liftHandler . runDBRead $ selectList [ UserSystemFunctionUser ==. uid, UserSystemFunctionIsOptOut ==. False ] [ Asc UserSystemFunctionFunction ]
in listCell' getFunctions i18nCell
, sortable Nothing (mempty & cellAttrs <>~ pure ("hide-columns--hider-label", mr MsgTableActionsHead)) $ \inp@DBRow{ dbrOutput = Entity uid _ } -> FormCell
{ formCellAttrs = []
@ -299,6 +299,12 @@ postUsersR = do
in E.maybe E.true (E.<=. E.val minTime) $ user E.^. UserLastLdapSynchronisation
| otherwise -> E.val True :: E.SqlExpr (E.Value Bool)
)
, ( "avs-sync", FilterColumn . E.mkExistsFilter $ \user criterion ->
E.from $ \usrAvs -> do
let minTime = (E.val criterion :: E.SqlExpr (E.Value UTCTime))
E.where_ $ usrAvs E.^. UserAvsUser E.==. user E.^. UserId
E.&&. usrAvs E.^. UserAvsLastSynch E.<=. minTime
)
, ( "user-company", FilterColumn . E.mkExistsFilter $ \user criterion ->
E.from $ \(usrComp `E.InnerJoin` comp) -> do
let testname = (E.val criterion :: E.SqlExpr (E.Value (CI Text))) `E.isInfixOf`
@ -343,6 +349,7 @@ postUsersR = do
, 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 "ldap-sync" . maybePrism _PathPiece) mPrev $ aopt utcTimeField (fslI MsgLdapSyncedBefore)
, prismAForm (singletonFilter "avs-sync" . maybePrism _PathPiece) mPrev $ aopt utcTimeField (fslI MsgLastAvsSyncedBefore)
]
, dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
, dbtParams = DBParamsForm

39
src/Handler/Utils/Avs.hs
View File

@ -171,11 +171,11 @@ lookupAvsUsers apis = do
updateReceivers :: UserId -> Handler (Entity User, [Entity User], Bool)
updateReceivers uid = do
-- First perform AVS update for receiver
runDB (getBy (UniqueUserAvsUser uid)) >>= \case
runDBRead (getBy (UniqueUserAvsUser uid)) >>= \case
Just Entity{entityVal=UserAvs{userAvsPersonId = apid}} -> catchAll2log $ upsertAvsUserById apid
Nothing -> return ()
-- Retrieve updated user and supervisors now
(underling :: Entity User, avsSupers :: [(E.Value UserId, E.Value (Maybe AvsPersonId))]) <- runDB $ (,)
(underling :: Entity User, avsSupers :: [(E.Value UserId, E.Value (Maybe AvsPersonId))]) <- runDBRead $ (,)
<$> getJustEntity uid
<*> (E.select $ do
(usrSuper :& usrAvs) <-
@ -194,7 +194,7 @@ updateReceivers uid = do
if null receiverIDs
then directResult
else do
receivers <- runDB $ selectList [UserId <-. receiverIDs] [] -- due to possible address updates, we must runDB once more and cannot join above
receivers <- runDBRead $ selectList [UserId <-. receiverIDs] [] -- due to possible address updates, we must runDB once more and cannot join above
if null receivers
then directResult
else return (underling, receivers, uid `elem` (entityKey <$> receivers))
@ -450,7 +450,7 @@ updateAvsUserByADC newAvsDataContact@(AvsDataContact apid newAvsPersonInfo newAv
linktoAvsUserByUIDs :: Set UserId -> Handler ()
linktoAvsUserByUIDs uids = do
ips <- runDB $ E.select $ do
ips <- runDBRead $ E.select $ do
usr <- E.from $ E.table @User
let uid = usr E.^. UserId
ipn = usr E.^. UserCompanyPersonalNumber
@ -484,18 +484,18 @@ createAvsUserById muid api = do
case Set.toList contactRes of
[] -> throwM $ AvsUserUnknownByAvs api
(_:_:_) -> throwM $ AvsUserAmbiguous api
[AvsDataContact{avsContactPersonInfo=cpi, avsContactFirmInfo=firmInfo, avsContactPersonID}]
[adc@AvsDataContact{avsContactPersonInfo=cpi, avsContactFirmInfo=firmInfo, avsContactPersonID}]
| avsContactPersonID /= api -> throwM $ AvsIdMismatch api avsContactPersonID
| otherwise -> do
-- check for matching existing user
let internalPersNo :: Maybe Text = cpi ^? _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo
persMail :: Maybe UserEmail = cpi ^? _avsInfoPersonEMail . _Just . from _CI
oldUsr <- runDB $ do
-- persMail :: Maybe UserEmail = cpi ^? _avsInfoPersonEMail . _Just . from _CI
oldUsr <- runDBRead $ do
mbUid <- if isJust muid
then return muid
else firstJustM $ catMaybes
[ internalPersNo <&> (\ipn -> getKeyByFilter [UserCompanyPersonalNumber ==. Just ipn]) -- must ensure filter isnt ==. Nothing
, persMail <&> guessUserByEmail
-- , persMail <&> guessUserByEmail -- this did not work, as unfortunately, superiors are sometimes listed under _avsInfoPersonEMail!
]
mbUAvs <- (getBy . UniqueUserAvsUser) `traverseJoin` mbUid
return (mbUid, mbUAvs)
@ -533,11 +533,11 @@ createAvsUserById muid api = do
, audFirstName = cpi ^. _avsInfoFirstName & Text.strip
, audSurname = cpi ^. _avsInfoLastName & Text.strip
, audDisplayName = cpi ^. _avsInfoDisplayName
, audDisplayEmail = persMail & fromMaybe mempty
, audEmail = persMail & fromMaybe ("AVSNO:" <> cpi ^. _avsInfoPersonNo . from _CI)
, audIdent = persMail & fromMaybe ("AVSID:" <> ciShow api )
, audDisplayEmail = adc ^. _avsContactPrimaryEmail . to (fromMaybe mempty) . from _CI
, audEmail = "AVSNO:" <> cpi ^. _avsInfoPersonNo . from _CI
, audIdent = "AVSID:" <> ciShow api
, audAuth = maybe AuthKindNoLogin (const AuthKindLDAP) internalPersNo
, audMatriculation = cpi ^. _avsInfoPersonNo & Just . tshow
, audMatriculation = cpi ^. _avsInfoPersonNo & Just
, audSex = Nothing
, audBirthday = cpi ^. _avsInfoDateOfBirth
, audMobile = cpi ^. _avsInfoPersonMobilePhoneNo
@ -676,9 +676,14 @@ upsertCompanySuperior (mbCid, newAfi) mbOldAfi = runMaybeT $ do
oldSup = snd <$> oldChanges
unless (supChange == Just False) $ do
-- upsert new superior company supervisor
mbMaxPrio <- E.selectOne $ do
usrCmp <- E.from $ E.table @UserCompany
E.where_ $ usrCmp E.^. UserCompanyUser E.==. E.val supid
return . E.max_ $ usrCmp E.^. UserCompanyPriority
let maxPrio = maybe 1 (fromMaybe 1 . E.unValue) mbMaxPrio
suprEnt <- upsertBy (UniqueUserCompany supid cid)
(UserCompany supid cid True False 1 True)
[UserCompanySupervisor =. True]
(UserCompany supid cid True False maxPrio True)
[UserCompanySupervisor =. True, UserCompanyPriority =. maxPrio]
E.insertSelectWithConflict UniqueUserSupervisor
(do
usr <- E.from $ E.table @UserCompany
@ -736,15 +741,15 @@ guessAvsUser :: Text -> Handler (Maybe UserId)
guessAvsUser (Text.splitAt 6 -> (Text.toUpper -> prefix, readMay -> Just nr))
| prefix=="AVSID:" =
let avsid = AvsPersonId nr in
runDB (getBy $ UniqueUserAvsId avsid) >>= \case
runDBRead (getBy $ UniqueUserAvsId avsid) >>= \case
(Just Entity{entityVal=UserAvs{userAvsUser=uid}}) -> return $ Just uid
Nothing -> catchAVS2message $ Just <$> upsertAvsUserById avsid
| prefix=="AVSNO:" =
runDB (view (_entityVal . _userAvsUser) <<$>> getByFilter [UserAvsNoPerson ==. nr])
runDBRead (view (_entityVal . _userAvsUser) <<$>> getByFilter [UserAvsNoPerson ==. nr])
guessAvsUser someid@(discernAvsCardPersonalNo -> Just someavsid) =
catchAVS2message $ upsertAvsUserByCard someavsid >>= \case
Nothing | Left{} <- someavsid -> -- attempt to find PersonalNumber in DB
runDB (getKeyByFilter [UserCompanyPersonalNumber ==. Just someid])
runDBRead (getKeyByFilter [UserCompanyPersonalNumber ==. Just someid])
other -> return other
guessAvsUser someid = do
try (runDB $ ldapLookupAndUpsert someid) >>= \case

2
src/Handler/Utils/AvsUpdate.hs
View File

@ -109,7 +109,7 @@ data CU_UserAvs_User
| CU_UA_UserMatrikelnummer
| CU_UA_UserCompanyPersonalNumber
| CU_UA_UserLdapPrimaryKey
-- CU_UA_UserDisplayEmail -- use _avsContactPrimaryEmailAddress instead
-- CU_UA_UserDisplayEmail -- use _avsContactPrimaryEmail instead
deriving (Show, Eq)
instance MkCheckUpdate CU_UserAvs_User where

10
src/Handler/Utils/Company.hs
View File

@ -40,16 +40,16 @@ wgtCompanies = \uid -> do
^{c}
$forall c <- otherCmp
<p>
#{c}
^{c}
|]
return $ toMaybe (notNull topCmp) resWgt
where
procCmp _ [] = (0, [],[])
procCmp _ [] = (0, [], [])
procCmp maxPri ((E.Value cmpSh, E.Value cmpName, E.Value cmpSpr, E.Value cmpPrio) : cs) =
let cmpWgt = companyWidget (cmpSh, cmpName, cmpSpr)
isTop = cmpPrio >= maxPri
let isTop = cmpPrio >= maxPri
cmpWgt = companyWidget isTop (cmpSh, cmpName, cmpSpr)
(accPri,accTop,accRem) = procCmp maxPri cs
in (max cmpPrio accPri, bool accTop (cmpWgt : accTop) isTop, bool (cmpName : accRem) accRem isTop) -- lazy evaluation after repmin example
in (max cmpPrio accPri, bool accTop (cmpWgt : accTop) isTop, bool (cmpWgt : accRem) accRem isTop) -- lazy evaluation after repmin example, don't factor out the bool!
-- TODO: use this function in company view Handler.Firm #157
-- | add all company supervisors for a given users

14
src/Handler/Utils/Qualification.hs
View File

@ -112,12 +112,14 @@ validQualification' cutoff qualUser =
E.&&. quserBlock' False cutoff qualUser
-- selectValidQualifications :: QualificationId -> [UserId] -> UTCTime -> DB [Entity QualificationUser]
selectValidQualifications ::
( MonadIO m
, BackendCompatible SqlBackend backend
, PersistQueryRead backend
, PersistUniqueRead backend
) => QualificationId -> [UserId] -> UTCTime -> ReaderT backend m [Entity QualificationUser]
-- selectValidQualifications ::
-- ( MonadIO m
-- , BackendCompatible SqlBackend backend
-- , PersistQueryRead backend
-- , PersistUniqueRead backend
-- ) => QualificationId -> [UserId] -> UTCTime -> ReaderT backend m [Entity QualificationUser]
selectValidQualifications :: (MonadIO m, E.SqlBackendCanRead backend)
=> QualificationId -> [UserId] -> UTCTime -> ReaderT backend m [Entity QualificationUser]
selectValidQualifications qid uids cutoff =
-- cutoff <- utctDay <$> liftIO getCurrentTime
E.select $ do

7
src/Handler/Utils/Table/Cells.hs
View File

@ -41,6 +41,9 @@ cellTell = flip tellCell
indicatorCell :: IsDBTable m Any => DBCell m Any -- For dbTables that return a Bool to indicate content
indicatorCell = writerCell . tell $ Any True
addIndicatorCell :: IsDBTable m Any => DBCell m Any -> DBCell m Any
addIndicatorCell = tellCell $ Any True
writerCell :: IsDBTable m w => WriterT w m () -> DBCell m w
writerCell act = mempty & cellContents %~ (<* act)
@ -51,6 +54,10 @@ cellMaybe = foldMap
maybeCell :: IsDBTable m b => Maybe a -> (a -> DBCell m b) -> DBCell m b
maybeCell = flip foldMap
boolCell :: IsDBTable m b => Bool -> DBCell m b -> DBCell m b
boolCell True c = c
boolCell False _ = mempty
htmlCell :: (IsDBTable m a, ToMarkup c) => c -> DBCell m a
htmlCell = cell . toWidget . toMarkup

15
src/Handler/Utils/Widgets.hs
View File

@ -62,7 +62,7 @@ userWidget :: HasUser c => c -> Widget
userWidget x = nameWidget (x ^. _userDisplayName) (x ^._userSurname)
userIdWidget :: UserId -> Widget
userIdWidget uid = maybeM (msg2widget MsgUserUnknown) userWidget (liftHandler $ runDB $ get uid)
userIdWidget uid = maybeM (msg2widget MsgUserUnknown) userWidget (liftHandler $ runDBRead $ get uid)
linkUserWidget :: HasRoute UniWorX url => (CryptoUUIDUser -> url) -> Entity User -> Widget
linkUserWidget lnk (Entity uid usr) = do
@ -71,7 +71,7 @@ linkUserWidget lnk (Entity uid usr) = do
-- | like linkUserWidget, but on Id only. Requires DB access, use with caution
linkUserIdWidget :: HasRoute UniWorX url => (CryptoUUIDUser -> url) -> UserId -> Widget
linkUserIdWidget lnk uid = maybeM (msg2widget MsgUserUnknown) (linkUserWidget lnk . Entity uid) (liftHandler $ runDB $ get uid)
linkUserIdWidget lnk uid = maybeM (msg2widget MsgUserUnknown) (linkUserWidget lnk . Entity uid) (liftHandler $ runDBRead $ get uid)
userEmailWidget :: HasUser c => c -> Widget
userEmailWidget x = nameEmailWidget (x ^. _userDisplayEmail) (x ^. _userDisplayName) (x ^. _userSurname)
@ -141,15 +141,20 @@ modalAccess wdgtNo wdgtYes writeAccess route = do
else wdgtNo
-- also see Handler.Utils.Table.Cells.companyCell
companyWidget :: (CompanyShorthand, CompanyName, Bool) -> Widget
companyWidget (csh, cname, isSupervisor) = simpleLink (toWgt name) curl
companyWidget :: Bool -> (CompanyShorthand, CompanyName, Bool) -> Widget
companyWidget isPrimary (csh, cname, isSupervisor)
| isPrimary, isSupervisor = simpleLink (toWgt $ name <> iconSupervisor) curl
| isPrimary = simpleLink (toWgt name ) curl
| isSupervisor = toWgt name <> simpleLink (toWgt iconSupervisor) curl
| otherwise = toWgt name
where
curl = FirmUsersR csh
corg = ciOriginal cname
name
| isSupervisor = text2markup (corg <> " ") <> icon IconSupervisor
| isSupervisor = text2markup (corg <> " ")
| otherwise = text2markup corg
----------
-- HEAT --
----------

2
src/Jobs/Handler/SynchroniseAvs.hs
View File

@ -101,7 +101,7 @@ dispatchJobSynchroniseAvs numIterations epoch iteration pause
dispatchJobSynchroniseAvsQueue :: JobHandler UniWorX
dispatchJobSynchroniseAvsQueue = JobHandlerException $ do
jobs <- runDB $ do
jobs <- runDBRead $ do
E.select (do
(avsSync :& usrAvs) <- E.from $ E.table @AvsSync
`E.leftJoin` E.table @UserAvs

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

101
templates/profileData.hamlet
View File

@ -15,11 +15,18 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
<dd .deflist__dd>
_{userAuthentication}
$maybe avs <- avsId
<dt .deflist__dt>
_{MsgAvsPersonNo}
^{messageTooltip tooltipAvsPersNo}
<dd .deflist__dd .ldap-primary-key>
#{view _userAvsNoPerson avs}
$with avsNoPers <- tshow (view _userAvsNoPerson avs)
<dt .deflist__dt>
_{MsgAvsPersonNo}
^{messageTooltip tooltipAvsPersNo}
$maybe matnr <- userMatrikelnummer
$if matnr /= avsNoPers
^{messageTooltip tooltipAvsPersNoDiffers}
<dd .deflist__dd .ldap-primary-key>
^{modalAccess (text2widget avsNoPers) (text2widget avsNoPers) False (AdminAvsUserR cID)}
$maybe matnr <- userMatrikelnummer
$if matnr /= avsNoPers
/ #{matnr}
$maybe avsError <- view _userAvsLastSynchError avs
<dt .deflist__dt>
_{MsgLastAvsSynchError}
@ -29,15 +36,18 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
_{MsgLastAvsSynchronisation}
<dd .deflist__dd>
^{formatTimeW SelFormatDateTime (view _userAvsLastSynch avs)}
$nothing
$maybe matnr <- userMatrikelnummer
<dt .deflist__dt>
_{MsgTableMatrikelNr}
^{messageTooltip tooltipAvsPersNo}
^{usrAutomatic CU_UA_UserMatrikelnummer}
<dd .deflist__dd>
^{modalAccess (text2widget matnr) (text2widget matnr) False (AdminAvsUserR cID)}
<dt .deflist__dt>
_{MsgNameSet} ^{usrAutomatic CU_UA_UserDisplayName}
<dd .deflist__dd>
^{nameWidget userDisplayName userSurname}
$maybe matnr <- userMatrikelnummer
<dt .deflist__dt>
_{MsgTableMatrikelNr} ^{usrAutomatic CU_UA_UserMatrikelnummer}
<dd .deflist__dd>
^{modalAccess (text2widget matnr) (text2widget matnr) False (AdminAvsUserR cID)}
$maybe sex <- userSex
<dt .deflist__dt>
_{MsgTableSex}
@ -84,6 +94,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
#{userEmail}
<dt .deflist__dt>
_{MsgAdminUserPinPassword}
^{usrAutomatic CU_UA_UserPinPassword}
<dd .deflist__dd>
$maybe pass <- userPinPassword
#{pass}
@ -114,18 +125,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 +196,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}
^{supervisorsWgt}
^{superviseesWgt}
<div .container>
<h2>_{MsgProfileQualifications}
<div .container>
^{qualificationsTable}
<div .container>
<h2>_{MsgProfileCourseExamResults}
<div .container>
^{examTable}
^{maybeTable MsgProfileCourses ownedCoursesTable}
<div .container>
<h2>_{MsgProfileTutorials}
<div .container>
^{ownTutorialTable}
^{maybeTable MsgProfileCourseParticipations enrolledCoursesTable}
<div .container>
<h2>_{MsgProfileTutorialParticipations}
<div .container>
^{tutorialTable}
^{maybeTable MsgProfileSubmissionGroups submissionGroupTable}
<div .container>
<h2>_{MsgProfileSubmissionGroups}
<div .container>
^{submissionGroupTable}
^{maybeTable' MsgProfileSubmissions Nothing (Just (msg2widget MsgProfileGroupSubmissionDates)) submissionTable}
<div .container>
<h2>_{MsgProfileSubmissions}
<div .container>
^{submissionTable}
<em>_{MsgProfileRemark}
\ _{MsgProfileGroupSubmissionDates}
^{maybeTable' MsgTableCorrector Nothing (Just (msg2widget MsgProfileCorrectorRemark <> simpleLinkI MsgProfileCorrections CorrectionsR)) correctionsTable}
<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}
^{profileRemarks}

8
test/Database/Fill.hs
View File

@ -656,12 +656,18 @@ fillDb = do
, let rcShort = CI.mk $ "RC" <> tshow n
]
void . insert' $ UserCompany jost fraportAg True True 0 False
void . insert' $ UserCompany svaupel nice True False 0 False
void . insert' $ UserCompany svaupel nice True False 2 False
void . insert' $ UserCompany svaupel ffacil False False 1 False
void . insert' $ UserCompany svaupel bpol True False 2 False
void . insert' $ UserCompany svaupel fraGround True False 1 False
void . insert' $ UserCompany gkleen nice False False 1 True
void . insert' $ UserCompany gkleen fraGround False True 2 False
void . insert' $ UserCompany gkleen bpol False True 1 False
void . insert' $ UserCompany fhamann bpol False False 1 True
void . insert' $ UserCompany fhamann ffacil True True 2 True
void . insert' $ UserCompany fhamann nice False False 3 False
void . insert' $ UserCompany sbarth nice False False 3 False
void . insert' $ UserCompany sbarth bpol True True 1 True
-- need more tests
insertMany_ [UserCompany uid fraGround False False 0 True | Entity uid User{userFirstName = "John"} <- matUsers]
insertMany_ [UserCompany uid bpol False False 0 False | Entity uid User{userFirstName = "Elizabeth"} <- matUsers]