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

Merge branch 'fradrive/localmaster'

Browse Source
This commit is contained in:
Steffen Jost 2023-05-02 16:51:32 +00:00
commit 7210b65dfe
47 changed files with 671 additions and 375 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
messages/auth/campus/de.msg
View File

@ -2,7 +2,7 @@
#
# SPDX-License-Identifier: AGPL-3.0-or-later
CampusIdentPlaceholder: V.Nachname@fraport.de
CampusIdent: Fraport AG Kennung
CampusIdentPlaceholder: V.Nachname@fraport.de / E12345
CampusIdent: Fraport Kennung
CampusPassword: Passwort
CampusPasswordPlaceholder: Passwort

4
messages/auth/campus/en.msg
View File

@ -2,7 +2,7 @@
#
# SPDX-License-Identifier: AGPL-3.0-or-later
CampusIdentPlaceholder: F.Last@fraport.de
CampusIdent: Fraport AG account
CampusIdentPlaceholder: F.Last@fraport.de / E12345
CampusIdent: Fraport account
CampusPassword: Password
CampusPasswordPlaceholder: Password

6
messages/uniworx/categories/authorization/de-de-formal.msg
View File

@ -96,9 +96,9 @@ TutorialNoCapacity: In dieser Übung sind keine Plätze mehr frei.
ExamOccurrenceNoCapacity: Zu diesem Termin/Raum sind keine Plätze mehr frei.
CourseNotEmpty: In diesem Kurs sind momentan Teilnehmer:innen angemeldet.
LDAPLoginTitle: Fraport AG Login (Büko)
PWHashLoginTitle: FRADrive Login
PWHashLoginNote: Verwenden Sie dieses Formular für zugesandte FRADrive Logindaten. Angestellte der Fraport AG sollten stattdessen den Büko-Login verwenden!
LDAPLoginTitle: Fraport Login für interne und externe Nutzer
PWHashLoginTitle: Spezieller Funktionsnutzer Login
PWHashLoginNote: Verwenden Sie dieses Formular nur, wenn Sie explizit dazu aufgefordert wurden. Alle anderen sollten das andere Login Formular verwenden!
DummyLoginTitle: Development-Login
InternalLdapError: Interner Fehler beim Fraport Büko-Login
CampusUserInvalidIdent: Konnte anhand des Fraport Büko-Logins keine eindeutige Identifikation ermitteln

6
messages/uniworx/categories/authorization/en-eu.msg
View File

@ -97,9 +97,9 @@ TutorialNoCapacity: Tutorial has reached maximum capacity
ExamOccurrenceNoCapacity: Occurrence/Room has reached maximum capacity
CourseNotEmpty: There are currently no participants enrolled for this course.
LDAPLoginTitle: Fraport AG login (Büko)
PWHashLoginTitle: FRADrive login
PWHashLoginNote: Use this form if you have received special FRADrive credentials. Fraport AG employees should use the Büko login instead!
LDAPLoginTitle: Fraport login for intern and extern users
PWHashLoginTitle: Special function user login
PWHashLoginNote: Only use this login form if you have received special instructions to do so. All others should use the other login field.
DummyLoginTitle: Development login
InternalLdapError: Internal error during Fraport Büko login
CampusUserInvalidIdent: Could not determine unique identification during Fraport Büko login

5
messages/uniworx/categories/qualification/de-de-formal.msg
View File

@ -25,9 +25,11 @@ TableQualificationBlockedTooltip: Wann wurde die Qualifikation vorübergehend au
TableQualificationBlockedTooltipSimple: Wann wurde die Qualifikation aus besonderem Grund wiederrufen?
TableQualificationNoRenewal: Auslaufend
TableQualificationNoRenewalTooltip: Es wird keine Benachrichtigung mehr versendet, wenn diese Qualifikation ablaufen sollte. Die Qualifikation kann noch weiterhin gültig sein.
QualificationScheduleRenewalTooltip: Wird eine Benachrichtigung versendet, falls diese Qualikation bald ablaufen sollte?
QualificationUserNoRenewal: Läuft ohne Benachrichtigung aus
QualificationUserNone: Für diese Person sind keine Qualifikationen registriert.
QualificationBlockReason: Entzugsbegründung
QualificationExpired: Ungültig seit
LmsUser: Inhaber
LmsURL: Link E‑Learning
TableLmsEmail: E‑Mail
@ -81,9 +83,10 @@ QualificationActExpire: Auslaufend markieren - keine Benachrichtigung zur Erneue
QualificationActUnexpire: Auslaufend aufheben - kostenpflichtige Benachrichtigung bei anstehender Erneuerung senden
QualificationSetExpire n@Int64: Benachrichtigung bei anstehender Erneuerung und E‑Learning abgeschaltet für #{n} #{pluralDE n "Person" "Personen"}
QualificationSetUnexpire n@Int64: Benachrichtigung bei anstehender Erneuerung und E‑Learning aktiviert für #{n} #{pluralDE n "Person" "Personen"}
QualificationActBlockSupervisor: Dauerhaft entziehen, mit sofortiger Wirkung
QualificationActBlockSupervisor: Dauerhaft entziehen und Ansprechpartner entfernen, mit sofortiger Wirkung
QualificationActBlock: Entziehen
QualificationActUnblock: Entzug löschen
QualificationActRenew: Qualifikation regulär verlängern
QualificationStatusBlock l@QualificationShorthand n@Int m@Int: #{n}/#{m} #{l} entzogen
QualificationStatusUnblock l@QualificationShorthand n@Int m@Int: #{n}/#{m} #{l} reaktiviert
LmsRenewalInstructions: Weitere Anweisungen zur Verlängerung finden Sie im angehängten PDF. Um Missbrauch zu verhindern wurde das PDF mit dem im FRADrive hinterlegten PDF-Passwort des Prüflings verschlüsselt. Falls kein PDF-Passwort manuell hinterlegt wurde, ist das PDF-Passwort die Flughafen Ausweisnummer, inklusive Punkt und der Ziffer danach.

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

@ -25,9 +25,11 @@ TableQualificationBlockedTooltip: Why and when was this qualification temporaril
TableQualificationBlockedTooltipSimple: When was this qualification revoked due to extraordinary reasons?
TableQualificationNoRenewal: Discontinued
TableQualificationNoRenewalTooltip: No renewal notifications will be send for this qualification upon expiry. The qualification may still be valid.
QualificationScheduleRenewalTooltip: Will there be a notification, if this qualification is about to expire soon?
QualificationUserNoRenewal: Expires without further notification
QualificationUserNone: No registered qualifications for this person.
QualificationBlockReason: Reason for revoking
QualificationExpired: Expired on
LmsUser: Licensee
LmsURL: Link E-learning
TableLmsEmail: Email
@ -81,9 +83,10 @@ QualificationActExpire: Discontinue - qualification expires silently
QualificationActUnexpire: Continue - send a possibly fee-paying notification upon due renewal
QualificationSetExpire n: Expiry notification and e‑learning deactivated for #{n} #{pluralENs n "person"}
QualificationSetUnexpire n: Expiry notification and e‑learning activated for #{n} #{pluralENs n "person"}
QualificationActBlockSupervisor: Waive permanently, effective immediately
QualificationActBlockSupervisor: Waive permanently and remove all supervisiors, effective immediately
QualificationActBlock: Revoke
QualificationActUnblock: Clear revocation
QualificationActRenew: Renew Qualification
QualificationStatusBlock l n m: #{n}/#{m} #{l} revoked
QualificationStatusUnblock l n m: #{n}/#{m} #{l} reactivated
LmsRenewalInstructions: Instruction on how to accomplish the renewal are enclosed in the attached PDF. In order to avoid misuse, the PDF is encrypted with the FRADrive PDF-password of the examinee. If no PDF-password had been chosen yet, then the password is the Fraport id card number of the examinee, including the punctuation mark and the digit thereafter.

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

@ -1,4 +1,4 @@
# SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
# SPDX-FileCopyrightText: 2023 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
#
# SPDX-License-Identifier: AGPL-3.0-or-later
@ -14,7 +14,7 @@ TermEnd: Ende Kursperiode
LectureStart: Beginn Kurse
TermEdited tid@TermId: Semester #{tid} erfolgreich editiert.
TermNewTitle: Semester editieren/anlegen.
InvalidInput: Eingaben bitte korrigieren.
InvalidInput: Ungültige Eingabe, bitte korrigieren.
Term !ident-ok: Semester
TermPlaceholder: JJJJ
TermStartDay: Erster Tag

2
messages/uniworx/categories/user/de-de-formal.msg
View File

@ -22,7 +22,7 @@ AdminUserPostAddress: Postalische Anschrift
AdminUserPrefersPostal: Briefe anstatt Email bevorzugt
AdminUserPinPassword: Passwort zur Verschlüsselung von PDF Anhängen in Emails
AdminUserNoPassword: Kein Passwort gesetzt
AdminUserAssimilate: Benutzer assimilieren
AdminUserAssimilate: Diesen Benutzer assimilieren von
UserAdded: Benutzer erfolgreich angelegt
UserCollision: Benutzer konnte wegen Eindeutigkeit nicht angelegt werden
HeadingUserAdd: Benutzer:in anlegen

2
messages/uniworx/categories/user/en-eu.msg
View File

@ -22,7 +22,7 @@ AdminUserPostAddress: Postal Address
AdminUserPrefersPostal: Prefers postal letters over email
AdminUserPinPassword: Password used for PDF attachments to emails
AdminUserNoPassword: No password set
AdminUserAssimilate: Assimilate user
AdminUserAssimilate: Assimilate user by another user
UserAdded: Successfully added user
UserCollision: Could not create user due to uniqueness constraint
HeadingUserAdd: Add user

2
messages/uniworx/utils/table_column/de-de-formal.msg
View File

@ -74,4 +74,6 @@ TableExamOfficeLabelStatus: Label-Farbe
TableExamOfficeLabelPriority: Label-Priorität
TableQualifications: Qualifikationen
TableCompany: Firma
TableCompanies: Firmen
TableCompanyNos: Firmennummern
TableSupervisor: Ansprechpartner

2
messages/uniworx/utils/table_column/en-eu.msg
View File

@ -74,4 +74,6 @@ TableExamOfficeLabelStatus: Label colour
TableExamOfficeLabelPriority: Label priority
TableQualifications: Qualifications
TableCompany: Company
TableCompanies: Companies
TableCompanyNos: Company numbers
TableSupervisor: Supervisor

6
messages/uniworx/utils/utils/de-de-formal.msg
View File

@ -1,4 +1,4 @@
# SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
# SPDX-FileCopyrightText: 2023 Steffen Jost <jost@tcs.ifi.lmu.de>,Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
#
# SPDX-License-Identifier: AGPL-3.0-or-later
@ -150,4 +150,6 @@ SheetGradingPassPoints': Bestehen nach Punkten
SheetGradingPassBinary': Bestanden/Nicht bestanden
SheetGradingPassAlways': Automatisch bestanden, sobald korrigiert
SheetTypeNormal !ident-ok: Normal
SheetTypeBonus !ident-ok: Bonus
SheetTypeBonus !ident-ok: Bonus
InvalidFormAction: Keine Aktion ausgeführt wegen ungültigen Formulardaten

6
messages/uniworx/utils/utils/en-eu.msg
View File

@ -1,4 +1,4 @@
# SPDX-FileCopyrightText: 2022 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
# SPDX-FileCopyrightText: 2023 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
#
# SPDX-License-Identifier: AGPL-3.0-or-later
@ -150,4 +150,6 @@ SheetGradingPassPoints': Passing by points
SheetGradingPassBinary': Pass/Fail
SheetGradingPassAlways': Automatically passed when corrected
SheetTypeNormal: Normal
SheetTypeBonus: Bonus
SheetTypeBonus: Bonus
InvalidFormAction: No action taken due to invalid form data

2
models/company.model
View File

@ -14,7 +14,7 @@ Company
UniqueCompanyShorthand shorthand
-- UniqueCompanyAvsId avsId -- should be the case, unclear if enforcing works here, since we cannot query avs by company id
Primary shorthand -- newtype Key Company = CompanyKey { unSchoolKey :: CompanyShorthand }
deriving Ord Eq Show Generic
deriving Ord Eq Show Generic Binary
-- TODO: a way to populate this table (manually)
CompanySynonym

2
package.yaml
View File

@ -147,6 +147,8 @@ dependencies:
- extended-reals
- rfc5051
- unidecode
- doctemplates
- doclayout
- pandoc
- pandoc-types
- typed-process

2
src/Handler/Admin.hs
View File

@ -137,7 +137,7 @@ mkUnreachableUsersTable = do
E.&&. E.not_ ((user E.^. UserEmail) `E.like` E.val "%@%.%")
pure user
dbtRowKey = (E.^. UserId)
dbtProj = dbtProjFilteredPostId -- TODO: still don't understand the choices here
dbtProj = dbtProjId
dbtColonnade =
-}

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

@ -530,15 +530,14 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do
return (usrAvs, user, qualUser, qual)
dbtRowKey = queryUserAvs >>> (E.^. UserAvsPersonId) -- ) &&& (queryQualification >>> (E.?. QualificationId)) -- WHY IS THIS AN ERROR?
-- Not sure what changes here:
dbtProj = dbtProjId -- Simple $ \(userAvs, user, qualUsr, quali) -> return (userAvs, user, qualUsr, quali)
-- dbtProj = dbtProjFilteredPostId
dbtProj = dbtProjId -- Simple $ \(userAvs, user, qualUsr, quali) -> return (userAvs, user, qualUsr, quali)
dbtColonnade = mconcat
[ dbSelect (applying _2) id $ return . view (resultUserAvs . _userAvsPersonId)
-- $ \DBRow{dbrOutput=(_,_,apid,_)} -> return apid -- return . view resultAvsPID -- does not type due to traversal
, colUserNameLink AdminUserR
, sortable (Just "avspersonno") (i18nCell MsgAvsPersonNo) $ \(view resultUserAvs -> a) -> avsPersonNoLinkedCell a
-- , colUserCompany
, sortable (Just "user-company") (i18nCell MsgTableCompany) $ \(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"
, 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
E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid
@ -554,6 +553,8 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do
, sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \(preview $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> cellMaybe dayCell d
, sortable (Just "blocked-due") (i18nCell MsgTableQualificationBlockedDue & cellTooltip MsgTableQualificationBlockedTooltip
) $ \(preview $ resultQualUser . _entityVal . _qualificationUserBlockedDue -> b) -> cellMaybe qualificationBlockedCell b
, sortable (Just "schedule-renew")(i18nCell MsgTableQualificationNoRenewal & cellTooltip MsgTableQualificationNoRenewalTooltip
) $ \(preview $ resultQualUser . _entityVal . _qualificationUserScheduleRenewal -> b) -> cellMaybe (flip ifIconCell IconNoNotification . not) b
, sortable Nothing (i18nCell MsgTableAvsActiveCards) $ \(view $ resultUserAvs . _userAvsPersonId -> apid) -> foldMap avsPersonCardCell $ Map.lookup apid apidStatus
]
dbtSorting = mconcat
@ -565,6 +566,7 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do
, single ("last-refresh" , SortColumn $ queryQualUser >>> (E.?. QualificationUserLastRefresh))
, single ("first-held" , SortColumn $ queryQualUser >>> (E.?. QualificationUserFirstHeld))
, single ("blocked-due" , SortColumn $ queryQualUser >>> (E.?. QualificationUserBlockedDue))
, single ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.?. QualificationUserScheduleRenewal))
]
dbtFilter = mconcat

307
src/Handler/LMS.hs
View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
-- SPDX-FileCopyrightText: 2023 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later
@ -25,7 +25,7 @@ import Import
import Jobs
import Handler.Utils
-- import Handler.Utils.Csv
import Handler.Utils.Users
import Handler.Utils.LMS
@ -47,7 +47,6 @@ import Handler.LMS.Userlist as Handler.LMS
import Handler.LMS.Result as Handler.LMS
import Handler.LMS.Fake as Handler.LMS -- TODO: remove in production!
-- import Handler.Utils.Qualification (validQualification)
-- avoids repetition of local definitions
single :: (k,a) -> Map k a
@ -105,26 +104,26 @@ resultAllQualificationActive = _dbrOutput . _2 . _unValue
resultAllQualificationTotal :: Lens' AllQualificationTableData Word64
resultAllQualificationTotal = _dbrOutput . _3 . _unValue
mkLmsAllTable :: Bool -> DB (Any, Widget)
mkLmsAllTable isAdmin = do
now <- liftIO getCurrentTime
svs <- getSupervisees
let
resultDBTable = DBTable{..}
where
dbtSQLQuery quali = do
let cusers = Ex.subSelectCount $ do
quser <- Ex.from $ Ex.table @QualificationUser
Ex.where_ $ quser Ex.^. QualificationUserQualification Ex.==. quali Ex.^. QualificationId
cactive = Ex.subSelectCount $ do
quser <- Ex.from $ Ex.table @QualificationUser
Ex.where_ $ quser Ex.^. QualificationUserQualification Ex.==. quali Ex.^. QualificationId
Ex.&&. validQualification (utctDay now) quser
let filterSvs luser = luser Ex.^. LmsUserQualification Ex.==. quali Ex.^. QualificationId
Ex.&&. (E.val isAdmin E.||. luser Ex.^. LmsUserUser `Ex.in_` E.vals svs)
cusers = Ex.subSelectCount $ do
luser <- Ex.from $ Ex.table @LmsUser
Ex.where_ $ filterSvs luser
cactive = Ex.subSelectCount $ do
luser <- Ex.from $ Ex.table @LmsUser
Ex.where_ $ filterSvs luser Ex.&&. E.isNothing (luser E.^. LmsUserStatus)
-- Failed attempt using Join/GroupBy instead of subselect: see branch csv-osis-demo-groupby-problem
return (quali, cactive, cusers)
dbtRowKey = (Ex.^. QualificationId)
dbtProj = dbtProjId -- TODO: or dbtProjSimple what is the difference?
dbtProj = dbtProjId
adminable = if isAdmin then sortable else \_ _ _ -> mempty
dbtColonnade = dbColonnade $ mconcat
[ colSchool $ resultAllQualification . _qualificationSchool
@ -195,38 +194,42 @@ postLmsEditR = error "TODO: STUB"
data LmsTableCsv = LmsTableCsv -- L..T..C.. -> ltc..
{ ltcDisplayName :: UserDisplayName
, ltcEmail :: UserEmail
, ltcValidUntil :: Day
, ltcLastRefresh :: Day
, ltcFirstHeld :: Day
, ltcBlockedDue :: Maybe QualificationBlocked
, ltcLmsIdent :: Maybe LmsIdent
, ltcLmsStatus :: Maybe LmsStatus
, ltcLmsStarted :: Maybe UTCTime
, ltcLmsDatePin :: Maybe UTCTime
, ltcLmsReceived :: Maybe UTCTime
, ltcLmsNotified :: Maybe UTCTime
, ltcLmsEnded :: Maybe UTCTime
{ ltcDisplayName :: UserDisplayName
, ltcEmail :: UserEmail
, ltcCompany :: Maybe Text
, ltcCompanyNumbers :: CsvSemicolonList Int
, ltcValidUntil :: Day
, ltcLastRefresh :: Day
, ltcFirstHeld :: Day
, ltcBlockedDue :: Maybe QualificationBlocked
, ltcLmsIdent :: Maybe LmsIdent
, ltcLmsStatus :: Maybe LmsStatus
, ltcLmsStarted :: Maybe UTCTime
, ltcLmsDatePin :: Maybe UTCTime
, ltcLmsReceived :: Maybe UTCTime
, ltcLmsNotified :: Maybe UTCTime
, ltcLmsEnded :: Maybe UTCTime
}
deriving Generic
makeLenses_ ''LmsTableCsv
ltcExample :: LmsTableCsv
ltcExample = LmsTableCsv
{ ltcDisplayName = "Max Mustermann"
, ltcEmail = "m.mustermann@example.com"
, ltcValidUntil = compDay
, ltcLastRefresh = compDay
, ltcFirstHeld = compDay
, ltcBlockedDue = Nothing
, ltcLmsIdent = Nothing
, ltcLmsStatus = Nothing
, ltcLmsStarted = Just compTime
, ltcLmsDatePin = Nothing
, ltcLmsReceived = Nothing
, ltcLmsNotified = Nothing
, ltcLmsEnded = Nothing
{ ltcDisplayName = "Max Mustermann"
, ltcEmail = "m.mustermann@example.com"
, ltcCompany = Just "Example Brothers LLC, SecondaryJobs Inc"
, ltcCompanyNumbers = CsvSemicolonList [27,69]
, ltcValidUntil = compDay
, ltcLastRefresh = compDay
, ltcFirstHeld = compDay
, ltcBlockedDue = Nothing
, ltcLmsIdent = Nothing
, ltcLmsStatus = Nothing
, ltcLmsStarted = Just compTime
, ltcLmsDatePin = Nothing
, ltcLmsReceived = Nothing
, ltcLmsNotified = Nothing
, ltcLmsEnded = Nothing
}
where
compTime :: UTCTime
@ -253,35 +256,37 @@ instance Csv.DefaultOrdered LmsTableCsv where
instance CsvColumnsExplained LmsTableCsv where
csvColumnsExplanations = genericCsvColumnsExplanations ltcOptions $ Map.fromList
[ ('ltcDisplayName, MsgLmsUser)
, ('ltcEmail , MsgTableLmsEmail)
, ('ltcValidUntil , MsgLmsQualificationValidUntil)
, ('ltcLastRefresh, MsgTableQualificationLastRefresh)
, ('ltcFirstHeld , MsgTableQualificationFirstHeld)
, ('ltcLmsIdent , MsgTableLmsIdent)
, ('ltcLmsStatus , MsgTableLmsStatus)
, ('ltcLmsStarted , MsgTableLmsStarted)
, ('ltcLmsDatePin , MsgTableLmsDatePin)
, ('ltcLmsReceived, MsgTableLmsReceived)
, ('ltcLmsEnded , MsgTableLmsEnded)
[ ('ltcDisplayName , SomeMessage MsgLmsUser)
, ('ltcEmail , SomeMessage MsgTableLmsEmail)
, ('ltcCompany , SomeMessage MsgTableCompanies)
, ('ltcCompanyNumbers , SomeMessage MsgTableCompanyNos)
, ('ltcValidUntil , SomeMessage MsgLmsQualificationValidUntil)
, ('ltcLastRefresh , SomeMessage MsgTableQualificationLastRefresh)
, ('ltcFirstHeld , SomeMessage MsgTableQualificationFirstHeld)
, ('ltcLmsIdent , SomeMessage MsgTableLmsIdent)
, ('ltcLmsStatus , SomeMessage MsgTableLmsStatus)
, ('ltcLmsStarted , SomeMessage MsgTableLmsStarted)
, ('ltcLmsDatePin , SomeMessage MsgTableLmsDatePin)
, ('ltcLmsReceived , SomeMessage MsgTableLmsReceived)
, ('ltcLmsEnded , SomeMessage MsgTableLmsEnded)
]
type LmsTableExpr = ( E.SqlExpr (Entity QualificationUser)
`E.InnerJoin` E.SqlExpr (Entity User)
) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity LmsUser))
type LmsTableExpr = E.SqlExpr (Entity QualificationUser)
`E.InnerJoin` E.SqlExpr (Entity User)
`E.InnerJoin` E.SqlExpr (Entity LmsUser)
queryQualUser :: LmsTableExpr -> E.SqlExpr (Entity QualificationUser)
queryQualUser = $(sqlIJproj 2 1) . $(sqlLOJproj 2 1)
queryQualUser = $(sqlIJproj 3 1)
queryUser :: LmsTableExpr -> E.SqlExpr (Entity User)
queryUser = $(sqlIJproj 2 2) . $(sqlLOJproj 2 1)
queryUser = $(sqlIJproj 3 2)
queryLmsUser :: LmsTableExpr -> E.SqlExpr (Maybe (Entity LmsUser))
queryLmsUser = $(sqlLOJproj 2 2)
queryLmsUser :: LmsTableExpr -> E.SqlExpr (Entity LmsUser)
queryLmsUser = $(sqlIJproj 3 3)
type LmsTableData = DBRow (Entity QualificationUser, Entity User, Maybe (Entity LmsUser), E.Value (Maybe [Maybe UTCTime]))
type LmsTableData = DBRow (Entity QualificationUser, Entity User, Entity LmsUser, E.Value (Maybe [Maybe UTCTime]), [Entity UserCompany])
resultQualUser :: Lens' LmsTableData (Entity QualificationUser)
resultQualUser = _dbrOutput . _1
@ -289,12 +294,15 @@ resultQualUser = _dbrOutput . _1
resultUser :: Lens' LmsTableData (Entity User)
resultUser = _dbrOutput . _2
resultLmsUser :: Traversal' LmsTableData (Entity LmsUser)
resultLmsUser = _dbrOutput . _3 . _Just
resultLmsUser :: Lens' LmsTableData (Entity LmsUser)
resultLmsUser = _dbrOutput . _3
resultPrintAck :: Traversal' LmsTableData [Maybe UTCTime]
resultPrintAck = _dbrOutput . _4 . _unValue . _Just
resultCompanyUser :: Lens' LmsTableData [Entity UserCompany]
resultCompanyUser = _dbrOutput . _5
instance HasEntity LmsTableData User where
hasEntity = resultUser
@ -330,71 +338,73 @@ isRenewPinAct LmsActRenewPinData = True
lmsTableQuery :: QualificationId -> LmsTableExpr
-> E.SqlQuery ( E.SqlExpr (Entity QualificationUser)
, E.SqlExpr (Entity User)
, E.SqlExpr (Maybe (Entity LmsUser))
, E.SqlExpr (Entity LmsUser)
, E.SqlExpr (E.Value (Maybe [Maybe UTCTime])) -- outer maybe indicates, whether a printJob exists, inner maybe indicates all acknowledged printJobs
)
lmsTableQuery qid (qualUser `E.InnerJoin` user `E.LeftOuterJoin` lmsUser) = do
lmsTableQuery qid (qualUser `E.InnerJoin` user `E.InnerJoin` lmsUser) = do
-- RECALL: another outer join on PrintJob did not work out well, since
-- - E.distinctOn [E.don $ printJob E.?. PrintJobLmsUser] $ do -- types, but destroys the ability to sort interactively, since distinctOn requires sorting;
-- - using noExsists on printJob join condition works, but only deliver single value;
-- experiments with separate sub-query showed that we would need two subsqueries to learn whether the request was indeed the latest
E.on $ user E.^. UserId E.=?. lmsUser E.?. LmsUserUser
E.&&. E.val qid E.=?. lmsUser E.?. LmsUserQualification -- NOTE: condition was once erroneously placed in where-clause, which does not work
E.on $ user E.^. UserId E.==. lmsUser E.^. LmsUserUser
E.&&. E.val qid E.==. lmsUser E.^. LmsUserQualification -- NOTE: condition was once erroneously placed in where-clause, which does not work
E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser
E.where_ $ E.val qid E.==. qualUser E.^. QualificationUserQualification
-- TODO: decide whether to use subSelect or LeftOuterJoin and delete the other!
-- Letztes Datum anzeigen, wenn mehrere, dann diese in klickbaren Tooltip verstecken!
let printAcknowledged = E.subSelectMaybe . E.from $ \pj -> do
E.where_ $ E.isJust (pj E.^. PrintJobLmsUser)
E.&&. ((lmsUser E.?. LmsUserIdent) E.==. (pj E.^. PrintJobLmsUser))
E.&&. ((lmsUser E.^. LmsUserIdent) E.=?. (pj E.^. PrintJobLmsUser))
let pjOrder = [E.desc $ pj E.^. PrintJobCreated, E.desc $ pj E.^. PrintJobAcknowledged] -- latest created comes first! This is assumed to be the case later on!
pure $ --(E.arrayAggWith E.AggModeAll (pj E.^. PrintJobCreated ) pjOrder, -- return two aggregates only works with select, the restricted typr of subSelect does not seem to support this!
E.arrayAggWith E.AggModeAll (pj E.^. PrintJobAcknowledged) pjOrder
return (qualUser, user, lmsUser, printAcknowledged)
mkLmsTable :: forall h p cols act act'.
( Functor h, ToSortable h
, Ord act, PathPiece act, RenderMessage UniWorX act
, AsCornice h p LmsTableData (DBCell (MForm Handler) (FormResult (First act', DBFormResult UserId Bool LmsTableData))) cols
mkLmsTable :: ( Functor h, ToSortable h
, AsCornice h p LmsTableData (DBCell (MForm Handler) (FormResult (First LmsTableActionData, DBFormResult UserId Bool LmsTableData))) cols
)
=> Bool
-> Entity Qualification
-> Map act (AForm Handler act')
-> cols
-> PSValidator (MForm Handler) (FormResult (First act', DBFormResult UserId Bool LmsTableData))
-> DB (FormResult (act', Set UserId), Widget)
-> Map LmsTableAction (AForm Handler LmsTableActionData)
-> (Map CompanyId Company -> cols)
-> PSValidator (MForm Handler) (FormResult (First LmsTableActionData, DBFormResult UserId Bool LmsTableData))
-> DB (FormResult (LmsTableActionData, Set UserId), Widget)
mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do
now <- liftIO getCurrentTime
currentRoute <- fromMaybe (error "mkLmsAllTable called from 404-handler") <$> liftHandler getCurrentRoute -- we know the route here
let
-- currentRoute = LmsR (qualificationSchool quali) (qualificationShorthand quali) -- bad idea as seen
-- lookup all companies
cmpMap <- memcachedBy (Just . Right $ 5 * diffMinute) ("CompanyDictionary"::Text) $ do
cmps <- selectList [] [Asc CompanyId]
return $ Map.fromAscList $ fmap (\c -> (entityKey c, entityVal c)) cmps
let
nowaday = utctDay now
mbRenewal = addGregorianDurationClip <$> qualificationRefreshWithin quali <*> Just nowaday
-- mbRenewal = addGregorianDurationClip <$> qualificationRefreshWithin quali <*> Just nowaday
csvName = T.replace " " "-" $ CI.original (quali ^. _qualificationName)
dbtIdent :: Text
dbtIdent = "qualification"
dbtSQLQuery q = lmsTableQuery qid q
dbtSQLQuery = lmsTableQuery qid
dbtRowKey = queryUser >>> (E.^. UserId)
dbtProj = dbtProjId
dbtColonnade = cols
dbtProj = dbtProjSimple $ \(qualUsr, usr, lmsUsr, printAcks) -> do
cmpUsr <- selectList [UserCompanyUser ==. entityKey usr] [Asc UserCompanyCompany]
return (qualUsr, usr, lmsUsr, printAcks, cmpUsr)
dbtColonnade = cols cmpMap
dbtSorting = mconcat
[ single $ sortUserNameLink queryUser
, single $ sortUserEmail queryUser
[ single $ sortUserNameLink queryUser
, single $ sortUserEmail queryUser
, single $ sortUserMatriclenr queryUser
, single ("valid-until" , SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserValidUntil))
, single ("last-refresh" , SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserLastRefresh))
, single ("first-held" , SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserFirstHeld))
, single ("blocked-due" , SortColumnNeverNull$ queryQualUser >>> (E.^. QualificationUserBlockedDue))
, single ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserScheduleRenewal))
, single ("lms-ident" , SortColumnNullsInv $ queryLmsUser >>> (E.?. LmsUserIdent))
, single ("lms-pin" , SortColumnNullsInv $ queryLmsUser >>> (E.?. LmsUserPin))
, single ("lms-status" , SortColumnNullsInv $ views (to queryLmsUser) (E.?. LmsUserStatus))
, single ("lms-started" , SortColumnNullsInv $ queryLmsUser >>> (E.?. LmsUserStarted))
, single ("lms-datepin" , SortColumnNullsInv $ queryLmsUser >>> (E.?. LmsUserDatePin))
, single ("lms-received" , SortColumnNullsInv $ queryLmsUser >>> (E.?. LmsUserReceived))
, single ("lms-notified" , SortColumnNullsInv $ queryLmsUser >>> (E.?. LmsUserNotified)) -- cannot include printJob acknowledge date
, single ("lms-ended" , SortColumnNullsInv $ queryLmsUser >>> (E.?. LmsUserEnded))
, single ("lms-ident" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserIdent))
, single ("lms-pin" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserPin))
, single ("lms-status" , SortColumnNullsInv $ views (to queryLmsUser) (E.^. LmsUserStatus))
, single ("lms-started" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserStarted))
, single ("lms-datepin" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserDatePin))
, single ("lms-received" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserReceived))
, single ("lms-notified" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserNotified)) -- cannot include printJob acknowledge date
, single ("lms-ended" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserEnded))
, single ( "user-company" , SortColumn $ \row -> E.subSelect $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId
@ -404,17 +414,17 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do
]
dbtFilter = mconcat
[ single $ fltrUserNameEmail queryUser
, single ("lms-ident" , FilterColumn . E.mkContainsFilterWith (Just . LmsIdent) $ views (to queryLmsUser) (E.?. LmsUserIdent))
, single ("lms-ident" , FilterColumn . E.mkContainsFilterWith LmsIdent $ views (to queryLmsUser) (E.^. LmsUserIdent))
-- , single ("lms-status" , FilterColumn . E.mkExactFilterLast $ views (to queryLmsUser) ((E.>=. E.val nowaday) . (E.^. LmsUserStatus))) -- LmsStatus cannot be filtered easily within the DB
-- , single ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) ((E.>=. E.val nowaday) . (E.^. QualificationUserValidUntil)))
, single ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification nowaday))
, single ("renewal-due" , FilterColumn $ \(queryQualUser -> quser) criterion ->
if | Just renewal <- mbRenewal
, Just True <- getLast criterion -> quser E.^. QualificationUserValidUntil E.<=. E.val renewal
E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val nowaday
| otherwise -> E.true
)
, single ("lms-notified", FilterColumn . E.mkExactFilterLast $ views (to queryLmsUser) (E.isJust . (E.?. LmsUserNotified)))
-- , single ("renewal-due" , FilterColumn $ \(queryQualUser -> quser) criterion ->
-- if | Just renewal <- mbRenewal
-- , Just True <- getLast criterion -> quser E.^. QualificationUserValidUntil E.<=. E.val renewal
-- E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val nowaday
-- | otherwise -> E.true
-- )
, single ("lms-notified", FilterColumn . E.mkExactFilterLast $ views (to queryLmsUser) (E.isJust . (E.^. LmsUserNotified)))
, single ("avs-number" , FilterColumn . E.mkExistsFilter $ \row criterion ->
E.from $ \usrAvs -> -- do
E.where_ $ usrAvs E.^. UserAvsUser E.==. queryUser row E.^. UserId
@ -428,18 +438,31 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do
testcrit = maybe testname testnumber $ readMay $ CI.original criterion
E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId E.&&. testcrit
)
)
, single ("avs-card" , FilterColumn . E.mkExistsFilter $ \row criterion ->
E.from $ \(usrAvs `E.InnerJoin` avsCard) -> do
E.on $ usrAvs E.^. UserAvsPersonId E.==. avsCard E.^. UserAvsCardPersonId
E.where_ $ usrAvs E.^. UserAvsUser E.==. queryUser row E.^. UserId
E.&&. ((E.explicitUnsafeCoerceSqlExprValue "citext" (avsCard E.^. UserAvsCardCardNo) :: E.SqlExpr (E.Value (CI Text)))
`E.hasInfix` (E.val criterion :: E.SqlExpr (E.Value (CI Text))))
)
, single ("personal-number", FilterColumn $ \(queryUser -> user) (criteria :: Set.Set Text) -> if
| Set.null criteria -> E.true
| otherwise -> E.any (\c -> user E.^. UserCompanyPersonalNumber `E.hasInfix` E.val c) criteria
)
]
dbtFilterUI mPrev = mconcat
[ fltrUserNameEmailHdrUI MsgLmsUser mPrev
, prismAForm (singletonFilter "lms-ident" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent)
-- , prismAForm (singletonFilter "lms-status" . maybePrism _PathPiece) mPrev $ aopt (selectField' (Just $ SomeMessage MsgTableNoFilter) $ return (optionsPairs [(MsgTableLmsSuccess,"success"::Text),(MsgTableLmsFailed,"blocked")])) (fslI MsgTableLmsStatus)
, prismAForm (singletonFilter "avs-number" ) mPrev $ aopt textField (fslI MsgAvsPersonNo)
[ prismAForm (singletonFilter "lms-ident" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent)
, fltrUserNameEmailHdrUI MsgLmsUser mPrev
, prismAForm (singletonFilter "user-company") mPrev $ aopt textField (fslI MsgTableCompany)
, prismAForm (singletonFilter "personal-number" ) mPrev $ aopt textField (fslI MsgCompanyPersonalNumber)
, prismAForm (singletonFilter "avs-card" ) mPrev $ aopt textField (fslI MsgAvsCardNo)
, prismAForm (singletonFilter "avs-number" ) mPrev $ aopt textField (fslI MsgAvsPersonNo)
, prismAForm (singletonFilter "validity" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsValid)
, prismAForm (singletonFilter "lms-notified" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsNotified)
, if isNothing mbRenewal then mempty
else prismAForm (singletonFilter "renewal-due" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsRenewal)
-- , prismAForm (singletonFilter "lms-status" . maybePrism _PathPiece) mPrev $ aopt (selectField' (Just $ SomeMessage MsgTableNoFilter) $ return (optionsPairs [(MsgTableLmsSuccess,"success"::Text),(MsgTableLmsFailed,"blocked")])) (fslI MsgTableLmsStatus)
-- , if isNothing mbRenewal then mempty
-- else prismAForm (singletonFilter "renewal-due" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsRenewal)
]
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
dbtCsvEncode = Just DBTCsvEncode
@ -456,6 +479,8 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do
doEncode' = LmsTableCsv
<$> view (resultUser . _entityVal . _userDisplayName)
<*> view (resultUser . _entityVal . _userDisplayEmail)
<*> (view resultCompanyUser >>= getCompanies)
<*> (view resultCompanyUser >>= getCompanyNos)
<*> view (resultQualUser . _entityVal . _qualificationUserValidUntil)
<*> view (resultQualUser . _entityVal . _qualificationUserLastRefresh)
<*> view (resultQualUser . _entityVal . _qualificationUserFirstHeld)
@ -467,12 +492,17 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do
<*> (join . preview (resultLmsUser . _entityVal . _lmsUserReceived))
<*> (join . preview (resultLmsUser . _entityVal . _lmsUserNotified)) -- TODO: only exports last email date / print job sending date, not print acknowledge
<*> (join . preview (resultLmsUser . _entityVal . _lmsUserEnded))
getCompanies cmps = case mapMaybe (flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany)) cmps of
[] -> pure Nothing
somecmps -> pure $ Just $ intercalate ", " $ fmap (view (_companyName . _CI)) somecmps
getCompanyNos = pure . CsvSemicolonList . mapMaybe (preview (_Just . _companyAvsId) . flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany))
dbtCsvDecode = Nothing
dbtExtraReps = []
dbtParams = if not isAdmin then def {dbParamsFormAction = Nothing, dbParamsFormSubmit = FormNoSubmit} else
DBParamsForm
{ dbParamsFormMethod = POST
, dbParamsFormAction = Just $ SomeRoute currentRoute
, dbParamsFormAction = Nothing -- Just $ SomeRoute currentRoute
, dbParamsFormAttrs = []
, dbParamsFormSubmit = FormSubmit
, dbParamsFormAdditional
@ -504,8 +534,7 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do
getLmsR, postLmsR :: SchoolId -> QualificationShorthand -> Handler Html
getLmsR = postLmsR
postLmsR sid qsh = do
isAdmin <- hasReadAccessTo AdminR
currentRoute <- fromMaybe (error "correctionsR called from 404-handler") <$> getCurrentRoute -- This should never be called from a 404 handler
isAdmin <- hasReadAccessTo AdminR
((lmsRes, lmsTable), Entity qid quali) <- runDB $ do
qent <- getBy404 $ SchoolQualificationShort sid qsh
let acts :: Map LmsTableAction (AForm Handler LmsTableActionData)
@ -515,20 +544,21 @@ postLmsR sid qsh = do
-- , singletonMap LmsActRenewPin $ pure LmsActRenewPinData
]
-- lmsStatusLink = toMaybe isAdmin LmsUserR
colChoices = mconcat
colChoices cmpMap = mconcat
[ if not isAdmin then mempty else dbSelectIf (applying _2) id (return . view (resultUser . _entityKey)) (\r -> isJust $ r ^? resultLmsUser) -- TODO: refactor using function "is"
, colUserNameModalHdr MsgLmsUser AdminUserR
, colUserEmail
, sortable (Just "user-company") (i18nCell MsgTableCompany) $ \( 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
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)]
return (comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor)
let companies = intersperse (text2markup ", ") $
(\(E.Value cmpName, E.Value cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> companies'
icnSuper = text2markup " " <> icon IconSupervisor
pure $ toWgt $ mconcat companies
, sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \( view resultCompanyUser -> cmps) ->
let icnSuper = text2markup " " <> icon IconSupervisor
cs = [ (cmpName, cmpSpr)
| Entity _ UserCompany{userCompanyCompany=cmpId, userCompanySupervisor=cmpSpr} <- cmps
, let cmpEnt = Map.lookup cmpId cmpMap
, Just Company{companyName = cmpName} <- [cmpEnt]
]
companies = intercalate (text2markup ", ") $
(\(cmpName, cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> cs
in wgtCell companies
, colUserMatriclenr
, sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) $ \( view $ resultQualUser . _entityVal . _qualificationUserValidUntil -> d) -> dayCell d
, sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \( view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> dayCell d
, sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \( view $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> dayCell d
@ -536,22 +566,22 @@ postLmsR sid qsh = do
) $ \( view $ resultQualUser . _entityVal . _qualificationUserBlockedDue -> b) -> qualificationBlockedCell b
, sortable (Just "schedule-renew")(i18nCell MsgTableQualificationNoRenewal & cellTooltip MsgTableQualificationNoRenewalTooltip
) $ \( view $ resultQualUser . _entityVal . _qualificationUserScheduleRenewal -> b) -> ifIconCell (not b) IconNoNotification
, sortable (Just "lms-ident") (i18nCell MsgTableLmsIdent) $ \(preview $ resultLmsUser . _entityVal . _lmsUserIdent . _getLmsIdent -> lid) -> foldMap textCell lid
, sortable (Just "lms-ident") (i18nCell MsgTableLmsIdent) $ \(view $ resultLmsUser . _entityVal . _lmsUserIdent . _getLmsIdent -> lid) -> textCell lid
, sortable (Just "lms-pin") (i18nCell MsgTableLmsPin & cellAttrs <>~ [("uw-hide-column-default-hidden",mempty)]
) $ \(preview $ resultLmsUser . _entityVal . _lmsUserPin -> pin) -> foldMap textCell pin
, sortable (Just "lms-status") (i18nCell MsgTableLmsStatus) $ \(preview $ resultLmsUser . _entityVal . _lmsUserStatus -> status) -> foldMap lmsStatusCell $ join status
, sortable (Just "lms-started") (i18nLms MsgTableLmsStarted) $ \(preview $ resultLmsUser . _entityVal . _lmsUserStarted -> d) -> foldMap dateTimeCell d
, sortable (Just "lms-datepin") (i18nLms MsgTableLmsDatePin) $ \(preview $ resultLmsUser . _entityVal . _lmsUserDatePin -> d) -> foldMap dateTimeCell d
, sortable (Just "lms-received") (i18nLms MsgTableLmsReceived) $ \(preview $ resultLmsUser . _entityVal . _lmsUserReceived -> d) -> foldMap dateTimeCell $ join d
--, sortable (Just "lms-notified") (i18nLms MsgTableLmsNotified) $ \(preview $ resultLmsUser . _entityVal . _lmsUserNotified -> d) -> foldMap dateTimeCell $ join d
, sortable (Just "lms-notified") (i18nLms MsgTableLmsNotified & cellTooltip MsgTableLmsNotifiedTooltip) $ \row ->
) $ \(view $ resultLmsUser . _entityVal . _lmsUserPin -> pin) -> textCell pin
, sortable (Just "lms-status") (i18nCell MsgTableLmsStatus) $ \(view $ resultLmsUser . _entityVal . _lmsUserStatus -> status) -> foldMap lmsStatusCell status
, sortable (Just "lms-started") (i18nLms MsgTableLmsStarted) $ \(view $ resultLmsUser . _entityVal . _lmsUserStarted -> d) -> dateTimeCell d
, sortable (Just "lms-datepin") (i18nLms MsgTableLmsDatePin) $ \(view $ resultLmsUser . _entityVal . _lmsUserDatePin -> d) -> dateTimeCell d
, sortable (Just "lms-received") (i18nLms MsgTableLmsReceived) $ \(view $ resultLmsUser . _entityVal . _lmsUserReceived -> d) -> foldMap dateTimeCell d
--, sortable (Just "lms-notified") (i18nLms MsgTableLmsNotified) $ \(view $ resultLmsUser . _entityVal . _lmsUserNotified -> d) -> foldMap dateTimeCell $ join d
, sortable (Just "lms-notified") (i18nLms MsgTableLmsNotified & cellTooltip MsgTableLmsNotifiedTooltip) $ \row ->
-- 4 Cases:
-- - No notification: LmsUserNotified == Nothing
-- - Email sent : LmsUserNotified == Just _ && PrintJobId == Nothing
-- - Letter printed : LmsUserNotified == Just _ && PrintJobId == Just _
-- - Letter sent : LmsUserNotified == Just _ && PrintJobId == Just _ && PrintJobAcknowledged == Just _
let notifyDate = join $ row ^? resultLmsUser . _entityVal . _lmsUserNotified
lmsident = row ^? resultLmsUser . _entityVal . _lmsUserIdent
let notifyDate = row ^. resultLmsUser . _entityVal . _lmsUserNotified
lmsident = row ^. resultLmsUser . _entityVal . _lmsUserIdent
recipient = row ^. hasUser
letterDates = row ^? resultPrintAck
lastLetterDate = headDef Nothing =<< letterDates
@ -561,7 +591,7 @@ postLmsR sid qsh = do
cDate = if | not letterSent -> foldMap dateTimeCell notifyDate
| Just d <- lastLetterDate -> dateTimeCell d
| otherwise -> i18nCell MsgPrintJobUnacknowledged
lprLink :: Maybe (Route UniWorX) = lmsident <&> (\lid -> urlRoute (PrintCenterR, [("print-job-lmsid", toPathPiece lid)]))
lprLink :: Route UniWorX = lmsident & (\lid -> urlRoute (PrintCenterR, [("print-job-lmsid", toPathPiece lid)]))
cAckDates = case letterDates of
Just ackDates@(_:_:_) -> spacerCell <> modalCell [whamlet|
<h1>
@ -573,11 +603,10 @@ postLmsR sid qsh = do
$maybe ackdate <- mbackdate
^{formatTimeW SelFormatDateTime ackdate}
$nothing
_{MsgPrintJobUnacknowledged}
$maybe lu <- lprLink
<p>
<a href=@{lu}>
_{MsgPrintJobs}
_{MsgPrintJobUnacknowledged}
<p>
<a href=@{lprLink}>
_{MsgPrintJobs}
|]
-- (PrintCenterR, [("pj-lmsid", toPathPiece lu)])
_ -> mempty
@ -586,7 +615,7 @@ postLmsR sid qsh = do
then mempty
else cIcon <> spacerCell <> cDate <> cAckDates
-- , sortable (Just "lms-notified-alternative") (i18nLms MsgTableLmsNotified) $ \(preview resultPrintAck -> d) -> textCell (show d)
, sortable (Just "lms-ended") (i18nLms MsgTableLmsEnded) $ \(preview $ resultLmsUser . _entityVal . _lmsUserEnded -> d) -> foldMap dateTimeCell $ join d
, sortable (Just "lms-ended") (i18nLms MsgTableLmsEnded) $ \(view $ resultLmsUser . _entityVal . _lmsUserEnded -> d) -> foldMap dateTimeCell d
]
where
-- i18nLms :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a
@ -613,7 +642,7 @@ postLmsR sid qsh = do
when (isRenewPinAct action) $ addMessageI Success $ MsgLmsPinRenewal numExaminees
when (isNotifyAct action) $ addMessageI Success $ MsgLmsNotificationSend numExaminees
when (diffSelected /= 0) $ addMessageI Warning $ MsgLmsActionFailed diffSelected
redirect currentRoute
reloadKeepGetParams $ LmsR sid qsh
let heading = citext2widget $ "LMS " <> qualificationName quali
siteLayout heading $ do

2
src/Handler/LMS/Result.hs
View File

@ -96,7 +96,7 @@ mkResultTable sid qsh qid = do
E.where_ $ lmsresult E.^. LmsResultQualification E.==. E.val qid
return lmsresult
dbtRowKey = (E.^. LmsResultId)
dbtProj = dbtProjFilteredPostId -- TODO: or dbtProjSimple what is the difference?
dbtProj = dbtProjId
dbtColonnade = dbColonnade $ mconcat
[ sortable (Just csvLmsIdent) (i18nCell MsgTableLmsIdent) $ \(view $ _dbrOutput . _entityVal . _lmsResultIdent . _getLmsIdent -> ident) -> textCell ident
, sortable (Just csvLmsSuccess) (i18nCell MsgTableLmsSuccess) $ \(view $ _dbrOutput . _entityVal . _lmsResultSuccess -> success) -> dayCell success

2
src/Handler/LMS/Userlist.hs
View File

@ -94,7 +94,7 @@ mkUserlistTable sid qsh qid = do
E.where_ $ lmslist E.^. LmsUserlistQualification E.==. E.val qid
return lmslist
dbtRowKey = (E.^. LmsUserlistId)
dbtProj = dbtProjFilteredPostId -- TODO: or dbtProjSimple what is the difference?
dbtProj = dbtProjId
dbtColonnade = dbColonnade $ mconcat
[ sortable (Just csvLmsIdent) (i18nCell MsgTableLmsIdent) $ \DBRow{ dbrOutput = Entity _ LmsUserlist{..} } -> textCell $ lmsUserlistIdent & getLmsIdent
, sortable (Just csvLmsBlocked) (i18nCell MsgTableLmsFailed) $ \DBRow{ dbrOutput = Entity _ LmsUserlist{..} } -> ifIconCell lmsUserlistFailed IconBlocked

5
src/Handler/LMS/Users.hs
View File

@ -95,7 +95,7 @@ mkUserTable _sid qsh qid = do
E.&&. E.isNothing (lmsuser E.^. LmsUserEnded)
return lmsuser
dbtRowKey = (E.^. LmsUserId)
dbtProj = dbtProjFilteredPostId -- TODO: or dbtProjSimple what is the difference?
dbtProj = dbtProjId
dbtColonnade = dbColonnade $ mconcat
[ sortable (Just csvLmsIdent) (i18nCell MsgTableLmsIdent) $ \(view $ _dbrOutput . _entityVal . _lmsUserIdent . _getLmsIdent -> ident) -> textCell ident
, sortable (Just csvLmsPin) (i18nCell MsgTableLmsPin & cellAttrs <>~ [("uw-hide-column-default-hidden",mempty)]
@ -177,7 +177,8 @@ getLmsUsersDirectR sid qsh = do
--csvRenderedHeader = lmsUserTableCsvHeader
--cvsRendered = CsvRendered {..}
csvRendered = toCsvRendered lmsUserTableCsvHeader $ lmsUser2csv cutoff . entityVal <$> lms_users
fmtOpts = def { csvIncludeHeader = lmsDownloadHeader
fmtOpts = (review csvPreset CsvPresetRFC)
{ csvIncludeHeader = lmsDownloadHeader
, csvDelimiter = lmsDownloadDelimiter
, csvUseCrLf = lmsDownloadCrLf
}

12
src/Handler/PrintCenter.hs
View File

@ -157,12 +157,11 @@ pjTableQuery (printJob `E.LeftOuterJoin` recipient
return (printJob, recipient, sender, course, quali)
mkPJTable :: DB (FormResult (PJTableActionData, Set PrintJobId), Widget)
mkPJTable = do
currentRoute <- fromMaybe (error "mkPJTable called from 404-handler") <$> liftHandler getCurrentRoute -- albeit we do know the route here
mkPJTable = do
let
dbtSQLQuery = pjTableQuery
dbtRowKey = queryPrintJob >>> (E.^. PrintJobId)
dbtProj = dbtProjFilteredPostId
dbtProj = dbtProjId
dbtColonnade = mconcat
[ dbSelectIf (applying _2) id (return . view (resultPrintJob . _entityKey)) (\r -> isNothing $ r ^. resultPrintJob . _entityVal . _printJobAcknowledged)
, sortable (Just "created") (i18nCell MsgPrintJobCreated) $ \( view $ resultPrintJob . _entityVal . _printJobCreated -> t) -> dateTimeCell t
@ -227,7 +226,7 @@ mkPJTable = do
dbtExtraReps = []
dbtParams = DBParamsForm
{ dbParamsFormMethod = POST
, dbParamsFormAction = Just $ SomeRoute currentRoute
, dbParamsFormAction = Nothing -- Just $ SomeRoute currentRoute
, dbParamsFormAttrs = []
, dbParamsFormSubmit = FormSubmit
, dbParamsFormAdditional
@ -254,8 +253,7 @@ mkPJTable = do
getPrintCenterR, postPrintCenterR :: Handler Html
getPrintCenterR = postPrintCenterR
postPrintCenterR = do
currentRoute <- fromMaybe (error "printCenterR called from 404-handler") <$> getCurrentRoute -- This should never be called from a 404 handler
postPrintCenterR = do
(pjRes, pjTable) <- runDB mkPJTable
formResult pjRes $ \case
@ -263,7 +261,7 @@ postPrintCenterR = do
now <- liftIO getCurrentTime
num <- runDB $ updateWhereCount [PrintJobAcknowledged ==. Nothing, PrintJobId <-. pjIds] [PrintJobAcknowledged =. Just now]
addMessageI Success $ MsgPrintJobAcknowledge num
redirect currentRoute
reloadKeepGetParams PrintCenterR
siteLayoutMsg MsgMenuApc $ do
setTitleI MsgMenuApc

226
src/Handler/Qualification.hs
View File

@ -1,9 +1,8 @@
-- SPDX-FileCopyrightText: 2022 Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
-- SPDX-FileCopyrightText: 2022-23 Steffen Jost <S.Jost@fraport.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later
{-# OPTIONS_GHC -fno-warn-orphans #-} -- needed for HasEntity instances
{-# OPTIONS -Wno-unused-top-binds #-} -- TODO: remove me, for debugging only
{-# LANGUAGE TypeApplications #-}
module Handler.Qualification
@ -17,7 +16,7 @@ import Import
-- import Jobs
import Handler.Utils
-- import Handler.Utils.Csv
import Handler.Utils.Users
import Handler.Utils.LMS
@ -46,9 +45,10 @@ getQualificationSchoolR :: SchoolId -> Handler Html
getQualificationSchoolR ssh = redirect (QualificationAllR, [("qualification-overview-school", toPathPiece ssh)])
getQualificationAllR :: Handler Html
getQualificationAllR = do -- TODO just a stub
getQualificationAllR = do
isAdmin <- hasReadAccessTo AdminR
qualiTable <- runDB $ do
view _2 <$> mkQualificationAllTable
view _2 <$> mkQualificationAllTable isAdmin
siteLayoutMsg MsgMenuQualifications $ do
setTitleI MsgMenuQualifications
$(widgetFile "qualification-all")
@ -63,15 +63,9 @@ resultAllQualificationActive = _dbrOutput . _2 . _unValue
resultAllQualificationTotal :: Lens' AllQualificationTableData Word64
resultAllQualificationTotal = _dbrOutput . _3 . _unValue
getSupervisees :: DB (Set UserId)
getSupervisees = do
uid <- requireAuthId
svs <- userSupervisorUser . entityVal <<$>> selectList [UserSupervisorSupervisor ==. uid] [Asc UserSupervisorUser]
return $ Set.insert uid $ Set.fromAscList svs
mkQualificationAllTable :: DB (Any, Widget)
mkQualificationAllTable = do
mkQualificationAllTable :: Bool -> DB (Any, Widget)
mkQualificationAllTable isAdmin = do
svs <- getSupervisees
now <- liftIO getCurrentTime
let
@ -79,7 +73,7 @@ mkQualificationAllTable = do
where
dbtSQLQuery quali = do
let filterSvs quser = quser Ex.^. QualificationUserQualification Ex.==. quali Ex.^. QualificationId
Ex.&&. quser Ex.^. QualificationUserUser `Ex.in_` E.vals svs
Ex.&&. (E.val isAdmin E.||. quser Ex.^. QualificationUserUser `Ex.in_` E.vals svs)
cusers = Ex.subSelectCount $ do
quser <- Ex.from $ Ex.table @QualificationUser
Ex.where_ $ filterSvs quser
@ -88,7 +82,7 @@ mkQualificationAllTable = do
Ex.where_ $ filterSvs quser Ex.&&. validQualification (utctDay now) quser
return (quali, cactive, cusers)
dbtRowKey = (Ex.^. QualificationId)
dbtProj = dbtProjId -- TODO: or dbtProjSimple what is the difference?
dbtProj = dbtProjId
dbtColonnade = dbColonnade $ mconcat
[ colSchool $ resultAllQualification . _qualificationSchool
, sortable (Just "qshort") (i18nCell MsgQualificationShort) $ \(view resultAllQualification -> quali) ->
@ -151,26 +145,32 @@ mkQualificationAllTable = do
-- postQualificationEditR = error "TODO"
data QualificationTableCsv = QualificationTableCsv -- Q..T..C.. -> qtc..
{ qtcDisplayName :: UserDisplayName
, qtcEmail :: UserEmail
, qtcValidUntil :: Day
, qtcLastRefresh :: Day
, qtcBlocked :: Maybe Day
, qtcLmsStatusTxt :: Maybe Text
, qtcLmsStatusDay :: Maybe Day
{ qtcDisplayName :: UserDisplayName
, qtcEmail :: UserEmail
, qtcCompany :: Maybe Text
, qtcCompanyNumbers :: CsvSemicolonList Int
, qtcValidUntil :: Day
, qtcLastRefresh :: Day
, qtcBlocked :: Maybe Day
, qtcScheduleRenewal:: Bool
, qtcLmsStatusTxt :: Maybe Text
, qtcLmsStatusDay :: Maybe Day
}
deriving Generic
makeLenses_ ''QualificationTableCsv
qtcExample :: QualificationTableCsv
qtcExample = QualificationTableCsv
{ qtcDisplayName = "Max Mustermann"
, qtcEmail = "m.mustermann@example.com"
, qtcValidUntil = compDay
, qtcLastRefresh = compDay
, qtcBlocked = Nothing
, qtcLmsStatusTxt = Just "Success"
, qtcLmsStatusDay = Just compDay
{ qtcDisplayName = "Max Mustermann"
, qtcEmail = "m.mustermann@example.com"
, qtcCompany = Just "Example Brothers LLC, SecondaryJobs Inc"
, qtcCompanyNumbers = CsvSemicolonList [27,69]
, qtcValidUntil = compDay
, qtcLastRefresh = compDay
, qtcBlocked = Nothing
, qtcScheduleRenewal= True
, qtcLmsStatusTxt = Just "Success"
, qtcLmsStatusDay = Just compDay
}
where
compTime :: UTCTime
@ -185,7 +185,7 @@ qtcOptions = Csv.defaultOptions { Csv.fieldLabelModifier = renameLtc }
renameLtc other = replaceLtc $ camelToPathPiece' 1 other
replaceLtc ('l':'m':'s':'-':t) = prefixLms t
replaceLtc other = other
prefixLms = ("e-learn-" <>)
prefixLms = ("elearn-" <>)
instance Csv.ToNamedRecord QualificationTableCsv where
toNamedRecord = Csv.genericToNamedRecord qtcOptions
@ -195,18 +195,21 @@ instance Csv.DefaultOrdered QualificationTableCsv where
instance CsvColumnsExplained QualificationTableCsv where
csvColumnsExplanations = genericCsvColumnsExplanations qtcOptions $ Map.fromList
[ ('qtcDisplayName, MsgLmsUser)
, ('qtcEmail , MsgTableLmsEmail)
, ('qtcValidUntil , MsgLmsQualificationValidUntil)
, ('qtcLastRefresh, MsgTableQualificationLastRefresh)
, ('qtcLmsStatusTxt, MsgTableLmsStatus)
, ('qtcLmsStatusDay, MsgTableLmsStatusDay)
[ ('qtcDisplayName , SomeMessage MsgLmsUser)
, ('qtcEmail , SomeMessage MsgTableLmsEmail)
, ('qtcCompany , SomeMessage MsgTableCompanies)
, ('qtcCompanyNumbers , SomeMessage MsgTableCompanyNos)
, ('qtcValidUntil , SomeMessage MsgLmsQualificationValidUntil)
, ('qtcLastRefresh , SomeMessage MsgTableQualificationLastRefresh)
, ('qtcScheduleRenewal, SomeMessage MsgQualificationScheduleRenewalTooltip)
, ('qtcLmsStatusTxt , SomeMessage MsgTableLmsStatus)
, ('qtcLmsStatusDay , SomeMessage MsgTableLmsStatusDay)
]
type QualificationTableExpr = ( E.SqlExpr (Entity QualificationUser)
`E.InnerJoin` E.SqlExpr (Entity User)
) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity LmsUser))
type QualificationTableExpr = ( E.SqlExpr (Entity QualificationUser)
`E.InnerJoin` E.SqlExpr (Entity User)
) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity LmsUser))
queryQualUser :: QualificationTableExpr -> E.SqlExpr (Entity QualificationUser)
queryQualUser = $(sqlIJproj 2 1) . $(sqlLOJproj 2 1)
@ -218,7 +221,7 @@ queryLmsUser :: QualificationTableExpr -> E.SqlExpr (Maybe (Entity LmsUser))
queryLmsUser = $(sqlLOJproj 2 2)
type QualificationTableData = DBRow (Entity QualificationUser, Entity User, Maybe (Entity LmsUser))
type QualificationTableData = DBRow (Entity QualificationUser, Entity User, Maybe (Entity LmsUser), [Entity UserCompany])
resultQualUser :: Lens' QualificationTableData (Entity QualificationUser)
resultQualUser = _dbrOutput . _1
@ -229,6 +232,9 @@ resultUser = _dbrOutput . _2
resultLmsUser :: Traversal' QualificationTableData (Entity LmsUser)
resultLmsUser = _dbrOutput . _3 . _Just
resultCompanyUser :: Lens' QualificationTableData [Entity UserCompany]
resultCompanyUser = _dbrOutput . _4
instance HasEntity QualificationTableData User where
hasEntity = resultUser
@ -242,21 +248,30 @@ data QualificationTableAction
| QualificationActBlockSupervisor
| QualificationActBlock
| QualificationActUnblock
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
| QualificationActRenew
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
instance Universe QualificationTableAction
instance Finite QualificationTableAction
nullaryPathPiece ''QualificationTableAction $ camelToPathPiece' 2
embedRenderMessage ''UniWorX ''QualificationTableAction id
-- Not yet needed, since there is no additional data for now:
{-
isAdminAct :: QualificationTableAction -> Bool
isAdminAct QualificationActExpire = False
isAdminAct QualificationActUnexpire = False
isAdminAct QualificationActBlockSupervisor = False
isAdminAct _ = True
-}
data QualificationTableActionData
= QualificationActExpireData
| QualificationActUnexpireData
| QualificationActBlockSupervisorData
| QualificationActBlockData { qualTableActBlockReason :: Text}
| QualificationActBlockData { qualTableActBlockReason :: Text}
| QualificationActUnblockData
deriving (Eq, Ord, Read, Show, Generic)
| QualificationActRenewData
deriving (Eq, Ord, Read, Show, Generic)
isExpiryAct :: QualificationTableActionData -> Bool
isExpiryAct QualificationActExpireData = True
@ -284,18 +299,21 @@ qualificationTableQuery qid fltr (qualUser `E.InnerJoin` user `E.LeftOuterJoin`
mkQualificationTable ::
( Functor h, ToSortable h
, AsCornice h p QualificationTableData (DBCell (MForm Handler) (FormResult (First QualificationTableActionData, DBFormResult UserId Bool QualificationTableData))) cols
, AsCornice h p QualificationTableData (DBCell (MForm Handler) (FormResult (First QualificationTableActionData, DBFormResult UserId Bool QualificationTableData))) cols
)
=> Bool
-> Entity Qualification
-> Map QualificationTableAction (AForm Handler QualificationTableActionData)
-> cols
-> (Map CompanyId Company -> cols)
-> PSValidator (MForm Handler) (FormResult (First QualificationTableActionData, DBFormResult UserId Bool QualificationTableData))
-> DB (FormResult (QualificationTableActionData, Set UserId), Widget)
mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
svs <- getSupervisees
now <- liftIO getCurrentTime
currentRoute <- fromMaybe (error "mkQualificationTable called from 404-handler") <$> liftHandler getCurrentRoute
now <- liftIO getCurrentTime
-- lookup all companies
cmpMap <- memcachedBy (Just . Right $ 5 * diffMinute) ("CompanyDictionary"::Text) $ do
cmps <- selectList [] [Asc CompanyId]
return $ Map.fromAscList $ fmap (\c -> (entityKey c, entityVal c)) cmps
let
nowaday = utctDay now
mbRenewal = addGregorianDurationClip <$> qualificationRefreshWithin quali <*> Just nowaday
@ -303,13 +321,21 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
dbtIdent :: Text
dbtIdent = "qualification"
fltrSvs = if isAdmin then const E.true else \quser -> quser E.^. QualificationUserUser `Ex.in_` E.vals svs
dbtSQLQuery q = qualificationTableQuery qid fltrSvs q
dbtSQLQuery = qualificationTableQuery qid fltrSvs
dbtRowKey = queryUser >>> (E.^. UserId)
dbtProj = dbtProjId -- FilteredPostId
dbtColonnade = cols
dbtProj = dbtProjSimple $ \(qualUsr, usr, lmsUsr) -> do
-- cmps <- 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 (entityKey usr)
-- E.orderBy [E.asc (comp E.^. CompanyName)]
-- return (comp E.^. CompanyName, comp E.^. CompanyAvsId, usrComp E.^. UserCompanySupervisor)
cmpUsr <- selectList [UserCompanyUser ==. entityKey usr] [Asc UserCompanyCompany]
return (qualUsr, usr, lmsUsr, cmpUsr)
dbtColonnade = cols cmpMap
dbtSorting = mconcat
[ single $ sortUserNameLink queryUser
, single $ sortUserEmail queryUser
[ single $ sortUserNameLink queryUser
, single $ sortUserEmail queryUser
, single $ sortUserMatriclenr queryUser
, single ("valid-until" , SortColumn $ queryQualUser >>> (E.^. QualificationUserValidUntil))
, single ("last-refresh" , SortColumn $ queryQualUser >>> (E.^. QualificationUserLastRefresh))
, single ("blocked-due" , SortColumnNeverNull $ queryQualUser >>> (E.^. QualificationUserBlockedDue))
@ -317,7 +343,7 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
-- , single ("lms-status" , SortColumn $ views (to queryLmsUser) (E.?. LmsUserStatus))
, single ("lms-status-plus",SortColumnNeverNull $ \row -> E.coalesce [E.explicitUnsafeCoerceSqlExprValue "timestamp" $ (queryLmsUser row E.?. LmsUserStatus) E.#>>. "{day}"
, queryLmsUser row E.?. LmsUserStarted])
, single ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserScheduleRenewal))
, single ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserScheduleRenewal))
, single ( "user-company" , SortColumn $ \row -> E.subSelect $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId
@ -332,15 +358,17 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
E.where_ $ usrAvs E.^. UserAvsUser E.==. queryUser row E.^. UserId
E.&&. ((E.val criterion :: E.SqlExpr (E.Value (CI Text))) E.==.
(E.explicitUnsafeCoerceSqlExprValue "citext" (usrAvs E.^. UserAvsNoPerson) :: E.SqlExpr (E.Value (CI Text))) ))
, single ("user-company", FilterColumn . E.mkExistsFilter $ \row criterion ->
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
testcrit = maybe testname testnumber $ readMay $ CI.original criterion
E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId E.&&. testcrit
)
, single ("avs-card" , FilterColumn . E.mkExistsFilter $ \row criterion ->
E.from $ \(usrAvs `E.InnerJoin` avsCard) -> do
E.on $ usrAvs E.^. UserAvsPersonId E.==. avsCard E.^. UserAvsCardPersonId
E.where_ $ usrAvs E.^. UserAvsUser E.==. queryUser row E.^. UserId
E.&&. ((E.explicitUnsafeCoerceSqlExprValue "citext" (avsCard E.^. UserAvsCardCardNo) :: E.SqlExpr (E.Value (CI Text)))
`E.hasInfix` (E.val criterion :: E.SqlExpr (E.Value (CI Text))))
)
, single ("personal-number", FilterColumn $ \(queryUser -> user) (criteria :: Set.Set Text) -> if
| Set.null criteria -> E.true
| otherwise -> E.any (\c -> user E.^. UserCompanyPersonalNumber `E.hasInfix` E.val c) criteria
)
, single ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification nowaday))
, single ("renewal-due" , FilterColumn $ \(queryQualUser -> quser) criterion ->
if | Just renewal <- mbRenewal
@ -351,8 +379,10 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
]
dbtFilterUI mPrev = mconcat
[ fltrUserNameEmailHdrUI MsgLmsUser mPrev
, prismAForm (singletonFilter "avs-number" ) mPrev $ aopt textField (fslI MsgAvsPersonNo)
, prismAForm (singletonFilter "user-company") mPrev $ aopt textField (fslI MsgTableCompany)
, prismAForm (singletonFilter "user-company") mPrev $ aopt textField (fslI MsgTableCompany)
, prismAForm (singletonFilter "personal-number" ) mPrev $ aopt textField (fslI MsgCompanyPersonalNumber)
, prismAForm (singletonFilter "avs-card" ) mPrev $ aopt textField (fslI MsgAvsCardNo)
, prismAForm (singletonFilter "avs-number" ) mPrev $ aopt textField (fslI MsgAvsPersonNo)
, prismAForm (singletonFilter "validity" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsValid)
, if isNothing mbRenewal then mempty
else prismAForm (singletonFilter "renewal-due" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsRenewal)
@ -372,11 +402,19 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
doEncode' = QualificationTableCsv
<$> view (resultUser . _entityVal . _userDisplayName)
<*> view (resultUser . _entityVal . _userDisplayEmail)
<*> (view resultCompanyUser >>= getCompanies)
<*> (view resultCompanyUser >>= getCompanyNos)
<*> view (resultQualUser . _entityVal . _qualificationUserValidUntil)
<*> view (resultQualUser . _entityVal . _qualificationUserLastRefresh)
<*> preview (resultQualUser . _entityVal . _qualificationUserBlockedDue . _Just . _qualificationBlockedDay)
<*> view (resultQualUser . _entityVal . _qualificationUserScheduleRenewal)
<*> getStatusPlusTxt
<*> getStatusPlusDay
getCompanies cmps = case mapMaybe (flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany)) cmps of
[] -> pure Nothing
somecmps -> pure $ Just $ intercalate ", " $ fmap (view (_companyName . _CI)) somecmps
getCompanyNos = pure . CsvSemicolonList . mapMaybe (preview (_Just . _companyAvsId) . flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany))
getStatusPlusTxt =
(join . preview (resultLmsUser . _entityVal . _lmsUserStatus)) >>= \case
Just LmsBlocked{} -> return $ Just "Failed"
@ -393,7 +431,7 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
dbtExtraReps = []
dbtParams = DBParamsForm
{ dbParamsFormMethod = POST
, dbParamsFormAction = Just $ SomeRoute currentRoute
, dbParamsFormAction = Nothing
, dbParamsFormAttrs = []
, dbParamsFormSubmit = FormSubmit
, dbParamsFormAdditional
@ -419,9 +457,8 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
getQualificationR, postQualificationR :: SchoolId -> QualificationShorthand -> Handler Html
getQualificationR = postQualificationR
postQualificationR sid qsh = do
currentRoute <- fromMaybe (error "correctionsR called from 404-handler") <$> getCurrentRoute -- This should never be called from a 404 handler
isAdmin <- hasReadAccessTo AdminR
postQualificationR sid qsh = do
isAdmin <- hasReadAccessTo AdminR
((lmsRes, qualificationTable), Entity qid quali) <- runDB $ do
qent@Entity{entityVal=Qualification{qualificationAuditDuration=auditMonths}} <- getBy404 $ SchoolQualificationShort sid qsh
let acts :: Map QualificationTableAction (AForm Handler QualificationTableActionData)
@ -429,28 +466,30 @@ postQualificationR sid qsh = do
[ singletonMap QualificationActExpire $ pure QualificationActExpireData
, singletonMap QualificationActUnexpire $ pure QualificationActUnexpireData
] ++ bool
[ singletonMap QualificationActBlockSupervisor $ pure QualificationActBlockSupervisorData ] -- nonAdmin Supervisor
[ singletonMap QualificationActUnblock $ pure QualificationActUnblockData
[ singletonMap QualificationActBlockSupervisor $ pure QualificationActBlockSupervisorData ] -- nonAdmin actions, ie. Supervisor
[ singletonMap QualificationActUnblock $ pure QualificationActUnblockData -- Admin-only actions
, singletonMap QualificationActBlock $ QualificationActBlockData
<$> apreq textField (fslI MsgQualificationBlockReason) Nothing
, singletonMap QualificationActRenew $ pure QualificationActRenewData
] isAdmin
linkLmsUser = toMaybe isAdmin LmsUserR
linkUserName = bool ForProfileR ForProfileDataR isAdmin
blockedDueCell = bool qualificationBlockedCellNoReason qualificationBlockedCell isAdmin
colChoices = mconcat
[ dbSelect (applying _2) id (return . view (resultUser . _entityKey))
colChoices cmpMap = mconcat
[ dbSelect (applying _2) id (return . view (hasEntity . _entityKey))
, colUserNameModalHdr MsgLmsUser linkUserName
, colUserEmail
, sortable (Just "user-company") (i18nCell MsgTableCompany) $ \( 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
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)]
return (comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor)
let companies = intersperse (text2markup ", ") $
(\(E.Value cmpName, E.Value cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> companies'
icnSuper = text2markup " " <> icon IconSupervisor
pure $ toWgt $ mconcat companies
, colUserEmail
, sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \( view resultCompanyUser -> cmps) ->
let icnSuper = text2markup " " <> icon IconSupervisor
cs = [ (cmpName, cmpSpr)
| Entity _ UserCompany{userCompanyCompany=cmpId, userCompanySupervisor=cmpSpr} <- cmps
, let cmpEnt = Map.lookup cmpId cmpMap
, Just Company{companyName = cmpName} <- [cmpEnt]
]
companies = intercalate (text2markup ", ") $
(\(cmpName, cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> cs
in wgtCell companies
, guardMonoid isAdmin colUserMatriclenr
, sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) $ \( view $ resultQualUser . _entityVal . _qualificationUserValidUntil -> d) -> dayCell d
, sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \( view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> dayCell d
, sortable (Just "blocked-due") (i18nCell MsgTableQualificationBlockedDue & cellTooltip MsgTableQualificationBlockedTooltipSimple
@ -467,7 +506,11 @@ postQualificationR sid qsh = do
tbl <- mkQualificationTable isAdmin qent acts colChoices psValidator
return (tbl, qent)
formResult lmsRes $ \case
formResult lmsRes $ \case
(QualificationActRenewData, selectedUsers) | isAdmin -> do
noks <- runDB $ renewValidQualificationUsers qid $ Set.toList selectedUsers
addMessageI (if noks > 0 && noks == Set.size selectedUsers then Success else Warning) $ MsgTutorialUserRenewedQualification noks
reloadKeepGetParams $ QualificationR sid qsh
(action, selectedUsers) | isExpiryAct action -> do
let isUnexpire = action == QualificationActUnexpireData
upd <- runDB $ updateWhereCount
@ -476,10 +519,11 @@ postQualificationR sid qsh = do
let msgKind = if upd > 0 then Success else Warning
msgVal = upd & if isUnexpire then MsgQualificationSetUnexpire else MsgQualificationSetExpire
addMessageI msgKind msgVal
redirect currentRoute
reloadKeepGetParams $ QualificationR sid qsh
(action, selectedUsers) | isBlockAct action && (isAdmin || action == QualificationActBlockSupervisorData) -> do
now <- liftIO getCurrentTime
let nowaday = utctDay now
selUserIds = Set.toList selectedUsers
qubr = case action of
QualificationActUnblockData -> Nothing
QualificationActBlockSupervisorData -> Just $ mkQualificationBlocked QualificationBlockReturnedByCompany nowaday
@ -488,7 +532,11 @@ postQualificationR sid qsh = do
, qualificationBlockedReason = qualTableActBlockReason
}
_ -> error "Handle.Qualification.isBlockAct returned non-block action"
oks <- runDB $ qualificationUserBlocking qid (Set.toList selectedUsers) qubr
oks <- runDB $ do
deleteWhere [UserSupervisorUser <-. selUserIds]
deleteWhere [UserCompanyUser <-. selUserIds]
qualificationUserBlocking qid selUserIds qubr
let nrq = length selectedUsers
warnLevel = if
| oks < 0 -> Error
@ -498,8 +546,8 @@ postQualificationR sid qsh = do
| isNothing qubr -> MsgQualificationStatusUnblock
| otherwise -> MsgQualificationStatusBlock
addMessageI warnLevel $ fbmsg qsh oks nrq
redirect currentRoute
_ -> addMessageI Error MsgUnauthorized
reloadKeepGetParams $ QualificationR sid qsh
_ -> addMessageI Error MsgInvalidFormAction
let heading = citext2widget $ qualificationName quali
siteLayout heading $ do

3
src/Handler/SAP.hs
View File

@ -97,7 +97,8 @@ getQualificationSAPDirectR = do
, qual Ex.^. QualificationSapId
)
let csvRendered = toCsvRendered sapUserTableCsvHeader $ sapRes2csv qualUsers
fmtOpts = def { csvIncludeHeader = True
fmtOpts = (review csvPreset CsvPresetRFC)
{ csvIncludeHeader = True
, csvDelimiter = ','
, csvUseCrLf = True
}

31
src/Handler/Users.hs
View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
-- SPDX-FileCopyrightText: 2022-23 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later
@ -45,7 +45,7 @@ import Auth.Dummy (apDummy)
hijackUserForm :: Form ()
hijackUserForm csrf = do
hijackUserForm = \csrf -> do
(btnResult, btnView) <- mopt (buttonField BtnHijack) "" Nothing
return (btnResult >>= guard . is _Just, mconcat [toWidget csrf, fvWidget btnView])
@ -100,7 +100,7 @@ postUsersR = do
(AdminUserR <$> encrypt uid)
(nameWidget userDisplayName userSurname)
, sortable (Just "matriculation") (i18nCell MsgTableMatrikelNr) $ \DBRow{ dbrOutput = entUsr } -> cellHasMatrikelnummerLinked entUsr
, sortable (Just "user-company") (i18nCell MsgTableCompany) $ \DBRow{ dbrOutput = Entity 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"
, sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \DBRow{ dbrOutput = Entity 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
E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid
@ -334,7 +334,7 @@ postUsersR = do
, dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
, dbtParams = DBParamsForm
{ dbParamsFormMethod = POST
, dbParamsFormAction = Just $ SomeRoute UsersR
, dbParamsFormAction = Nothing -- Just $ SomeRoute (UsersR, [("users-user-company","fraport")])
, dbParamsFormAttrs = []
, dbParamsFormSubmit = FormSubmit
, dbParamsFormAdditional
@ -351,21 +351,21 @@ postUsersR = do
, dbtExtraReps = []
}
-- $logInfoS "UsersFormResult" $ tshow usersRes
formResult usersRes $ \case
(act, usersSet)
| Set.null usersSet && isNotSetSupervisor act -> do
addMessageI Info MsgActionNoUsersSelected
redirect UsersR
| Set.null usersSet && isNotSetSupervisor act ->
addMessageI Info MsgActionNoUsersSelected
(UserLdapSyncData, userSet) -> do
runDBJobs . forM_ userSet $ \uid -> queueDBJob $ JobSynchroniseLdapUser uid
addMessageI Success . MsgSynchroniseLdapUserQueued $ Set.size userSet
redirect UsersR
addMessageI Success . MsgSynchroniseLdapUserQueued $ Set.size userSet
redirectKeepGetParams UsersR
(UserHijack, Set.minView -> Just (uid, _)) ->
hijackUser uid >>= sendResponse
(UserRemoveSupervisorData, userSet) -> do
runDB $ deleteWhere [UserSupervisorUser <-. Set.toList userSet]
addMessageI Success $ MsgUsersRemoveSupervisors $ Set.size userSet
redirect UsersR
redirectKeepGetParams UsersR
(act, usersSet)
| isActionSupervisor act -> do
avsUsers :: Map Text (Maybe UserId) <- sequenceA $ Map.fromSet guessAvsUser $ getActionSupervisors act
@ -382,8 +382,8 @@ postUsersR = do
if nrSuperNotFound > 0
then addMessageI Warning $ MsgUsersChangeSupervisorsWarning (Set.size usersSet) (length supersFound) nrSuperNotFound
else addMessageI Success $ MsgUsersChangeSupervisorsSuccess (Set.size usersSet) (length supersFound)
redirect UsersR
_other -> error "Should not be possible"
redirectKeepGetParams UsersR
_other -> addMessageI Error MsgInvalidFormAction
((allUsersRes, allUsersWgt), allUsersEnctype) <- runFormPost . identifyForm FIDAllUsersAction $ buttonForm
@ -563,8 +563,8 @@ postAdminUserR uuid = do
redirect $ AdminUserR uuid
let assimilateForm' = renderAForm FormStandard $
areq (checkMap (first $ const MsgAssimilateUserNotFound) Right $ userField False Nothing) (fslI MsgUserAssimilateUser) Nothing
assimilateAction oldUserId = do
res <- try . runDB . setSerializable $ assimilateUser uid oldUserId
assimilateAction newUserId = do
res <- try . runDB . setSerializable $ assimilateUser newUserId uid
case res of
Left (err :: UserAssimilateException) ->
addMessageModal Error (i18n MsgAssimilateUserHaveError) $ Right
@ -583,7 +583,8 @@ postAdminUserR uuid = do
#{tshow warning}
|]
addMessageI Success MsgAssimilateUserSuccess
redirect $ AdminUserR uuid
newUuid <- encrypt newUserId
redirect $ AdminUserR newUuid
((rightsResult, rightsFormWidget), rightsFormEnctype) <- runFormPost . identifyForm FIDUserRights $ userRightsForm
((authResult, authFormWidget), authFormEnctype) <- runFormPost . identifyForm FIDUserAuthentication $ userAuthenticationForm
((systemFunctionsResult, systemFunctionsWidget), systemFunctionsEnctype) <- runFormPost . identifyForm FIDUserSystemFunctions $ renderAForm FormStandard systemFunctionsForm'

21
src/Handler/Utils.hs
View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
-- SPDX-FileCopyrightText: 2023 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later
@ -137,3 +137,22 @@ redirectAlternatives = go
Just xs' -> over _1 (x :) $ nunsnoc xs'
nsnoc [] x = x :| []
nsnoc (x' : xs) x = x' :| (xs ++ [x])
-- | redirect to currentRoute, if Just otherwise to given default
reload :: (MonadHandler m, HandlerSite m ~ UniWorX) => Route (HandlerSite m) -> m a
reload r = getCurrentRoute >>= redirect . fromMaybe r
-- | like `reload`, preserving all GET parameters
reloadKeepGetParams :: (MonadHandler m, HandlerSite m ~ UniWorX) => Route (HandlerSite m) -> m a
reloadKeepGetParams r = liftHandler $ do
getps <- reqGetParams <$> getRequest
route <- fromMaybe r <$> getCurrentRoute
-- addMessage Info $ toHtml (show getps) -- DEBUG ONLY
-- RECALL: redirect GET parameters are used like so: -- redirect (UsersR, [("users-user-company","fraport")])
redirect (route, getps)
-- | redirect preserving all GET parameters
redirectKeepGetParams :: (MonadHandler m, HandlerSite m ~ UniWorX) => Route (HandlerSite m) -> m a
redirectKeepGetParams route = liftHandler $ do
getps <- reqGetParams <$> getRequest
redirect (route, getps)

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

@ -8,7 +8,8 @@ module Handler.Utils.DateTime
( utcToLocalTime, utcToZonedTime
, localTimeToUTC, TZ.LocalToUTCResult(..), localTimeToUTCSimple
, toTimeOfDay
, toMidnight, beforeMidnight, toMidday, toMorning, addHours
, toMidnight, beforeMidnight, toMidday, toMorning
, toFullHour, roundDownToMinutes, addHours
, formatDiffDays, formatCalendarDiffDays
, formatTime'
, formatTime, formatTimeUser, formatTimeW, formatTimeMail
@ -68,6 +69,18 @@ toMidnight = toTimeOfDay 0 0 0
toMidday :: Day -> UTCTime
toMidday = toTimeOfDay 12 0 0
-- | Round up to next full hour
toFullHour :: UTCTime -> UTCTime
toFullHour t = t{utctDayTime=rounded}
where
rounded = fromInteger $ 3600 * (1 + (truncate (utctDayTime t) `div` 3600))
roundDownToMinutes :: Integer -> UTCTime -> UTCTime
roundDownToMinutes f t = t{utctDayTime=rounded}
where
rounded = fromInteger $ factor * (truncate (utctDayTime t) `div` factor)
factor = 60 * f
-- | One second before the end of day
beforeMidnight :: Day -> UTCTime
beforeMidnight = toTimeOfDay 23 59 59

3
src/Handler/Utils/LMS.hs
View File

@ -45,7 +45,8 @@ getLmsCsvDecoder :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m, From
getLmsCsvDecoder = do
LmsConf{..} <- getsYesod $ view _appLmsConf
if | Just upDelim <- lmsUploadDelimiter -> do
let fmtOpts = def { csvDelimiter = upDelim
let fmtOpts = (review csvPreset CsvPresetRFC)
{ csvDelimiter = upDelim
, csvIncludeHeader = lmsUploadHeader
}
csvOpts = def { csvFormat = fmtOpts }

4
src/Handler/Utils/Table/Columns.hs
View File

@ -718,7 +718,7 @@ fltrRelevantStudyFeaturesSemesterUI = fltrFeaturesSemesterUI
{-
-- colUserCompany :: (HandlerSite (DBCell m) ~ UniWorX, IsDBTable m c, HasEntity a User) => Colonnade Sortable a (DBCell m c)
colUserCompany = sortable (Just "user-company") (i18nCell MsgTableCompany) $ \heu -> do
colUserCompany = sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \heu -> do
let uid = heu ^. hasEntity . _entityKey
companies' <- liftHandler . runDB . E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid
@ -732,7 +732,7 @@ colUserCompany = sortable (Just "user-company") (i18nCell MsgTableCompany) $ \he
-- PROBLEM: how to type sqlCell compatible with dbTable that as actions, i.e. MForm instead of YesodDB?
colUserCompany :: (IsDBTable (YesodDB UniWorX) c, HasEntity a User) => Colonnade Sortable a (DBCell (YesodDB UniWorX) c)
colUserCompany = sortable (Just "user-company") (i18nCell MsgTableCompany) $ \heu ->
colUserCompany = sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \heu ->
let uid = heu ^. hasEntity . _entityKey in
sqlCell $ do
companies' <- E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do

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

@ -716,6 +716,7 @@ dbtProjId' :: forall fs r r'.
=> ReaderT (DBTProjCtx fs r) (MaybeT (ReaderT SqlBackend (HandlerFor UniWorX))) r'
dbtProjId' = view _dbtProjRow
-- | Reicht das Ergebnis der SQL-Abfrage direkt durch an colonnade und csv
dbtProjId :: forall fs r r'.
( fs ~ (), DBRow r ~ r' )
=> ReaderT (DBTProjCtx fs r) (MaybeT (ReaderT SqlBackend (HandlerFor UniWorX))) r'
@ -727,6 +728,7 @@ dbtProjSimple' :: forall fs r r' r''.
-> ReaderT (DBTProjCtx fs r) (MaybeT (ReaderT SqlBackend (HandlerFor UniWorX))) r'
dbtProjSimple' cont = (views _dbtProjRow . set _dbrOutput) <=< (hoist lift . magnify (_dbtProjRow . _dbrOutput)) $ lift . cont =<< ask
-- | Transformation des SQL Ergbnistyp vor dem Weiterreichen an colonnade oder csv durch eine einfache monadische Funktion
dbtProjSimple :: forall fs r r' r''.
( fs ~ (), DBRow r'' ~ r' )
=> (r -> DB r'')
@ -743,11 +745,14 @@ withFilteredPost proj = do
guardM . lift . lift $ p r'
return r'
-- | Wie `dbtProjId` plus zusätzliches Filtern der SQL-Abfrage in Haskell
-- Nur zu Verwenden, wenn Filter mit mkFilterProjectedPost verwendet werden; ein Typfehler weist daraufhin, wenn dies nötig ist!
dbtProjFilteredPostId :: forall fs r r'.
( fs ~ DBTProjFilterPost r', DBRow r ~ r' )
=> ReaderT (DBTProjCtx fs r) (MaybeT (ReaderT SqlBackend (HandlerFor UniWorX))) r'
dbtProjFilteredPostId = withFilteredPost dbtProjId'
-- | Kombination aus `dbtProjFilteredPostId` und `dbtProjSimple`, d.h. Ergeniszeilen in Haskell transformieren und filtern
dbtProjFilteredPostSimple :: forall fs r r' r''.
( fs ~ DBTProjFilterPost r', DBRow r'' ~ r' )
=> (r -> DB r'')
@ -964,7 +969,7 @@ instance Monoid' x => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) En
instance Default (DBParams (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX)) x) where
def = DBParamsForm
{ dbParamsFormMethod = POST
, dbParamsFormAction = Nothing
, dbParamsFormAction = Nothing -- Recall: Nothing preserves GET Parameters
, dbParamsFormAttrs = []
, dbParamsFormSubmit = FormSubmit
, dbParamsFormAdditional = \_ -> return (pure (), mempty)

78
src/Handler/Utils/Users.hs
View File

@ -18,6 +18,7 @@ module Handler.Utils.Users
, getPostalAddress, getPostalPreferenceAndAddress
, abbrvName
, getReceivers
, getSupervisees
) where
import Import
@ -34,7 +35,7 @@ import qualified Data.Aeson as JSON
import qualified Data.Aeson.Types as JSON
import qualified Data.Set as Set
import qualified Data.List as List
-- import qualified Data.List as List
import qualified Data.CaseInsensitive as CI
import qualified Database.Esqueleto.Legacy as E
@ -110,6 +111,13 @@ getReceivers uid = do
then directResult
else return (underling, receivers, uid `elem` (entityKey <$> receivers))
-- | return underlings for currently logged in user
getSupervisees :: DB (Set UserId)
getSupervisees = do
uid <- requireAuthId
svs <- userSupervisorUser . entityVal <<$>> selectList [UserSupervisorSupervisor ==. uid] [Asc UserSupervisorUser]
return $ Set.insert uid $ Set.fromAscList svs
computeUserAuthenticationDigest :: AuthenticationMode -> Digest SHA3_256
computeUserAuthenticationDigest = hashlazy . JSON.encode
@ -287,6 +295,16 @@ assimilateUser :: UserId -- ^ @newUserId@
--
-- Fatal errors are thrown, non-fatal warnings are returned
assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
-- retrieve user entities first, to ensure they both exist
(oldUserEnt, newUserEnt) <- do
oldUser <- getEntity oldUserId
newUser <- getEntity newUserId
case (oldUser, newUser) of
(Just old, Just new) -> return (old,new)
_ -> tellError UserAssimilateCouldNotDetermineUserIdents
let oldUser = oldUserEnt ^. _entityVal
newUser = newUserEnt ^. _entityVal
E.insertSelectWithConflict
UniqueCourseFavourite
(E.from $ \courseFavourite -> do
@ -859,18 +877,56 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
(\current _excluded -> [ UserCompanySupervisor E.=. (current E.^. UserCompanySupervisor)] )
deleteWhere [ UserCompanyUser ==. oldUserId]
userIdents <- E.select . E.from $ \user -> do
E.where_ $ user E.^. UserId `E.in_` E.valList [newUserId, oldUserId]
return ( user E.^. UserId
, user E.^. UserIdent
)
case (,) <$> List.lookup (E.Value oldUserId) userIdents <*> List.lookup (E.Value newUserId) userIdents of
Just (E.Value oldIdent, E.Value newIdent')
| oldIdent /= newIdent' -> audit $ TransactionUserIdentChanged oldIdent newIdent'
| otherwise -> return ()
_other -> tellError UserAssimilateCouldNotDetermineUserIdents
mbOldAvsId <- getBy $ UniqueUserAvsUser oldUserId
mbNewAvsId <- getBy $ UniqueUserAvsUser newUserId
case (mbOldAvsId,mbNewAvsId) of
(Nothing, _)
-> return ()
(Just Entity{entityVal=UserAvs{userAvsPersonId=oldAvsId}}, Just _)
-> deleteWhere [UserAvsCardPersonId ==. oldAvsId] >> deleteBy (UniqueUserAvsUser oldUserId)
(Just Entity{entityVal=oldUserAvs}, Nothing)
-> -- deleteBy $ UniqueUserAvsUser oldUserId -- maybe we need this due to double uniqueness?!
void $ upsertBy (UniqueUserAvsId (oldUserAvs ^. _userAvsPersonId)) oldUserAvs{userAvsUser=newUserId} [UserAvsUser =. newUserId]
-- merge some optional / incomplete user fields
let mergeBy :: forall a . PersistField a => (a -> a -> Bool) -> EntityField User a -> Maybe (Update User)
mergeBy cmp uf = let ufl = fieldLens uf
oldV = oldUserEnt ^. ufl
newV = newUserEnt ^. ufl
in toMaybe (cmp oldV newV) (uf =. oldV)
mergeMaybe :: forall b . PersistField b => EntityField User (Maybe b) -> Maybe (Update User)
mergeMaybe = mergeBy (\oldV newV -> isNothing newV && isJust oldV)
update newUserId $ catMaybes -- NOTE: persist does shortcircuit null updates as expected
[ mergeMaybe UserLdapPrimaryKey
, mergeBy (<) UserAuthentication
, mergeBy (>) UserLastAuthentication
, mergeBy (<) UserCreated
, toMaybe (not (validEmail' (newUser ^. _userEmail )) && validEmail' (oldUser ^. _userEmail))
(UserEmail =. oldUser ^. _userEmail)
, toMaybe (not (validEmail' (newUser ^. _userDisplayEmail)) && validEmail' (oldUser ^. _userDisplayEmail))
(UserDisplayEmail =. oldUser ^. _userDisplayEmail)
, mergeMaybe UserMatrikelnummer
, toMaybe (isNothing (newUser ^. _userPostAddress) && isJust (oldUser ^. _userPostAddress))
(UserPostAddress =. oldUser ^. _userPostAddress)
, toMaybe (isNothing (newUser ^. _userPostAddress) && isJust (oldUser ^. _userPostAddress))
(UserPostLastUpdate =. oldUser ^. _userPostLastUpdate)
, toMaybe ((isJust (newUser ^. _userPostAddress) || isJust (oldUser ^. _userPostAddress))
&& (newUser ^. _userPrefersPostal || oldUser ^. _userPrefersPostal))
(UserPrefersPostal =. True)
, mergeMaybe UserPinPassword
, mergeMaybe UserLanguages
, mergeMaybe UserSex
, mergeMaybe UserBirthday
, mergeMaybe UserTelephone
, mergeMaybe UserMobile
]
delete oldUserId
let oldUsrIdent = oldUser ^. _userIdent
newUsrIdent = newUser ^. _userIdent
when (oldUsrIdent /= newUsrIdent) $ audit $ TransactionUserIdentChanged oldUsrIdent newUsrIdent
audit $ TransactionUserAssimilated newUserId oldUserId
where
tellWarning :: UserAssimilateExceptionReason -> ReaderT SqlBackend (WriterT (Set UserAssimilateException) Handler) ()

6
src/Model/Types/Avs.hs
View File

@ -197,6 +197,7 @@ discernAvsCardPersonalNo _ = Nothing
newtype AvsPersonId = AvsPersonId { avsPersonId :: Int } -- untagged Int
deriving (Eq, Ord, Generic)
deriving newtype (NFData, PathPiece, PersistField, PersistFieldSql, Csv.ToField, Csv.FromField, Hashable, Binary)
-- TODO: consider using "makeWrapped ''AvsPersonId"
instance E.SqlString AvsPersonId
-- As opposed to AvsObjPersonId, AvsPersonId is an untagged Int with respect to FromJSON/ToJSON, as needed by AVS API;
instance FromJSON AvsPersonId where
@ -590,6 +591,7 @@ deriveJSON defaultOptions
type AvsResponseStatus :: Type
newtype AvsResponseStatus = AvsResponseStatus (Set AvsStatusPerson)
deriving (Eq, Ord, Show, Generic)
makeWrapped ''AvsResponseStatus
deriveJSON defaultOptions
{ fieldLabelModifier = dropCamel 2
, omitNothingFields = True
@ -601,6 +603,7 @@ instance Semigroup AvsResponseStatus where
newtype AvsResponsePerson = AvsResponsePerson (Set AvsDataPerson)
deriving (Eq, Ord, Show, Generic)
-- makeWrapped ''AvsResponsePerson
deriveJSON defaultOptions
{ fieldLabelModifier = dropCamel 2
, omitNothingFields = True
@ -610,6 +613,7 @@ deriveJSON defaultOptions
newtype AvsResponseContact = AvsResponseContact (Set AvsDataContact)
deriving (Eq, Ord, Show, Generic)
makeWrapped ''AvsResponseContact
deriveJSON defaultOptions
{ fieldLabelModifier = dropCamel 2
, omitNothingFields = True
@ -666,10 +670,12 @@ deriveJSON defaultOptions
newtype AvsQueryStatus = AvsQueryStatus (Set AvsPersonId)
deriving (Eq, Ord, Show, Generic)
deriveJSON defaultOptions ''AvsQueryStatus
makeWrapped ''AvsQueryStatus
newtype AvsQueryContact = AvsQueryContact (Set AvsObjPersonId) -- note the difference to AvsQueryStatus, which receives a list of id, whereas here we sent a list of single-field object
deriving (Eq, Ord, Show, Generic)
deriveJSON defaultOptions ''AvsQueryContact
makeWrapped ''AvsQueryContact
newtype AvsQueryGetLicences = AvsQueryGetLicences AvsObjPersonId -- this should have been a set, but the specification was implemented differently
deriving (Eq, Ord, Show, Generic)

3
src/Model/Types/Csv.hs
View File

@ -85,7 +85,8 @@ instance Default CsvOptions where
}
instance Default CsvFormatOptions where
def = csvPreset # CsvPresetRFC
def = csvPreset # CsvPresetRFC -- DO NOT CHANGE!
-- Changing the default to CsvPresetXlsx will cause internal server errors due to partial record selectors failing, like `csvIncludeHeader`
data CsvPreset = CsvPresetRFC
| CsvPresetXlsx

42
src/Utils/Avs.hs
View File

@ -34,8 +34,8 @@ type AVSSetRampLicences = "RampDrivingLicence" :> ReqBody '[JSON] AvsQueryS
avsMaxSetLicenceAtOnce :: Int
avsMaxSetLicenceAtOnce = 90 -- maximum input set size for avsQuerySetLicences as enforced by AVS
avsMaxGetStatusAtOnce :: Int
avsMaxGetStatusAtOnce = 900 -- maximum input set size for avsQueryStatus as enforced by AVS
avsMaxQueryAtOnce :: Int
avsMaxQueryAtOnce = 900 -- maximum input set size for avsQueryStatus as enforced by AVS
avsApi :: Proxy AVS
@ -78,10 +78,10 @@ mkAvsQuery _ _ _ = AvsQuery
}
#else
mkAvsQuery baseUrl basicAuth cliEnv = AvsQuery
{ avsQueryPerson = \q -> liftIO $ catch404toEmpty <$> runClientM (rawQueryPerson q) cliEnv
, avsQueryStatus = \q -> liftIO $ runClientM (splitQueryStatus q) cliEnv
, avsQueryContact = \q -> liftIO $ runClientM (rawQueryContact q) cliEnv
, avsQuerySetLicences = \q -> liftIO $ runClientM (rawQuerySetLicences q) cliEnv
{ avsQueryPerson = \q -> liftIO $ catch404toEmpty <$> runClientM (rawQueryPerson q) cliEnv
, avsQueryStatus = \q -> liftIO $ runClientM (splitQuery rawQueryStatus q) cliEnv
, avsQueryContact = \q -> liftIO $ runClientM (splitQuery rawQueryContact q) cliEnv
, avsQuerySetLicences = \q -> liftIO $ runClientM (rawQuerySetLicences q) cliEnv -- TODO: currently uses setLicencesAvs for splitting to ensure return of correctly set licences
-- , avsQueryGetLicences = \q -> liftIO $ runClientM (rawQueryGetLicences q) cliEnv
, avsQueryGetAllLicences = liftIO $ runClientM (rawQueryGetLicences avsQueryAllLicences) cliEnv
}
@ -96,25 +96,17 @@ mkAvsQuery baseUrl basicAuth cliEnv = AvsQuery
| baseUrl == base = Right $ AvsResponsePerson mempty -- WORKAROUND: AVS server erroneously returns 404 if no matching person could be found in its database!
catch404toEmpty other = other
-- TODO: make a generic implementation for this
splitQueryStatus :: AvsQueryStatus -> ClientM AvsResponseStatus
splitQueryStatus q@(AvsQueryStatus avids)
| Set.size avids <= avsMaxGetStatusAtOnce = rawQueryStatus q
| otherwise = do
let (avid_1,avid_2) = Set.splitAt avsMaxGetStatusAtOnce avids
res1 <- rawQueryStatus (AvsQueryStatus avid_1)
res2 <- splitQueryStatus (AvsQueryStatus avid_2)
return $ res1 <> res2
-- splitQuery :: (a -> Set b) -> (Set b -> a) -> (a -> ClientM c) -> a -> ClientM c
-- splitQuery toSet fromSet rawQuery q
-- | Set.size (toSet q) <= avsMaxGetStatusAtOnce = rawQueryStatus q
-- | otherwise = do
-- let (fromSet -> avid_1,fromSet -> avid_2) = Set.splitAt avsMaxGetStatusAtOnce (toSet q)
-- res1 <- rawQuery avid_1
-- res2 <- splitQuery toSet fromSet rawQuery avid_2
-- return $ fromSet (toSet res1 <> toSet res2)
splitQuery :: (Wrapped a, Wrapped c, Unwrapped a ~ Set b, Semigroup (Unwrapped c))
=> (a -> ClientM c) -> a -> ClientM c
splitQuery rawQuery q
| Set.size s <= avsMaxQueryAtOnce = rawQuery q
| otherwise = do
let (avsid1, avsid2) = Set.splitAt avsMaxQueryAtOnce s
res1 <- rawQuery $ view _Unwrapped' avsid1
res2 <- splitQuery rawQuery $ view _Unwrapped' avsid2
return $ view _Unwrapped' (res1 ^. _Wrapped' <> res2 ^. _Wrapped')
where
s = view _Wrapped' q
#endif
-----------------------

6
src/Utils/Form.hs
View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022 Felix Hamann <felix.hamann@campus.lmu.de>,Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Wolfgang Witt <Wolfgang.Witt@campus.lmu.de>
-- SPDX-FileCopyrightText: 2023 Felix Hamann <felix.hamann@campus.lmu.de>,Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Wolfgang Witt <Wolfgang.Witt@campus.lmu.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later
@ -307,7 +307,8 @@ data FormIdentifier
| FIDAvsQueryLicence
| FIDAvsSetLicence
| FIDBtnAvsImportUnknown
| FIDBtnAvsRevokeUnknown
| FIDBtnAvsRevokeUnknown
| FIDHijackUser
deriving (Eq, Ord, Read, Show)
instance PathPiece FormIdentifier where
@ -1089,6 +1090,7 @@ wrapForm' :: Button site button => button -> WidgetT site IO () -> FormSettings
wrapForm' btn formWidget FormSettings{..} = do
formId <- maybe newIdent (return . toPathPiece) formAnchor
formActionUrl <- traverse toTextUrl formAction
let hasAction = isJust formActionUrl
$(widgetFile "widgets/form/form")

2
src/Utils/Lens.hs
View File

@ -128,7 +128,7 @@ makeClassyFor_ ''LmsResult
makeClassyFor_ ''UserAvs
makeClassyFor_ ''UserAvsCard
makeClassyFor_ ''UserCompany
makeLenses_ ''UserCompany
makeLenses_ ''Company
_entityKey :: Getter (Entity record) (Key record)

30
src/Utils/Print.hs
View File

@ -42,6 +42,7 @@ import Text.Hamlet
import System.Exit
import System.Process.Typed -- for calling pdftk for pdf encryption
import Handler.Utils.Memcached
import Handler.Utils.Users
import Handler.Utils.DateTime
import Handler.Utils.Mail
@ -49,6 +50,7 @@ import Handler.Utils.Widgets (nameHtml')
import Handler.Utils.Avs (updateReceivers)
import Jobs.Handler.SendNotification.Utils
import Utils.Print.Instances ()
import Utils.Print.Letters
import Utils.Print.RenewQualification
import Utils.Print.CourseCertificate
@ -108,26 +110,29 @@ import Utils.Print.CourseCertificate
-- | read and writes markdown, applying it as its own template to apply meta
mdTemplating :: Text -> P.Meta -> HandlerFor UniWorX (Either P.PandocError P.Pandoc)
mdTemplating :: Text -> P.Meta -> HandlerFor UniWorX (Either Text P.Pandoc)
mdTemplating template meta = runExceptT $ do
let readerOpts = def { P.readerExtensions = P.pandocExtensions
, P.readerStripComments = True
}
doc <- ExceptT $ $cachedHereBinary ("pandoc: \n" <> template) (pure . P.runPure $ P.readMarkdown readerOpts template)
tmpl <- ExceptT $ $cachedHereBinary ("template: \n" <> template) (pure . P.runPure $ compileTemplate template)
-- doc <- ExceptT (pure . over _Left P.renderError . P.runPure $ P.readMarkdown readerOpts template)
-- tmpl <- ExceptT (pure . over _Left P.renderError . P.runPure $ compileTemplate template)
doc <- ExceptT $ memcachedBy (Just . Right $ 6 * diffHour) ("pandoc-md: \n" <> template) (pure . over _Left P.renderError . P.runPure $ P.readMarkdown readerOpts template)
tmpl <- ExceptT $ memcachedBy (Just . Right $ 6 * diffHour) ("template-md: \n" <> template) (pure . over _Left P.renderError . P.runPure $ compileTemplate template)
let writerOpts = def { P.writerExtensions = P.pandocExtensions
, P.writerTemplate = Just tmpl
}
ExceptT . pure . P.runPure $ do
ExceptT . pure . over _Left P.renderError . P.runPure $ do
md_txt <- P.writeMarkdown writerOpts $ appMeta setIsDeFromLang $ addMeta meta doc
P.readMarkdown readerOpts md_txt
-- | creates a PDF using a LaTeX template
pdfLaTeX :: LetterKind -> P.Pandoc -> HandlerFor UniWorX (Either P.PandocError LBS.ByteString)
pdfLaTeX :: LetterKind -> P.Pandoc -> HandlerFor UniWorX (Either Text LBS.ByteString)
pdfLaTeX lk doc = do
e_tmpl <- $cachedHereBinary ("LetterKind:" <> tshow lk) (liftIO . P.runIO $ compileTemplate $ templateLatex lk)
actRight e_tmpl $ \tmpl -> liftIO . P.runIO $ do
-- e_tmpl <- fmap (over _Left P.renderError) . liftIO . P.runIO $ compileTemplate $ templateLatex lk
e_tmpl <- memcachedBy (Just . Right $ 6 * diffHour) ("LetterKind-latex: \n" <> tshow lk) (fmap (over _Left P.renderError) . liftIO . P.runIO $ compileTemplate $ templateLatex lk)
actRight e_tmpl $ \tmpl -> fmap (over _Left P.renderError) .liftIO . P.runIO $ do
let writerOpts = def { P.writerExtensions = P.pandocExtensions
, P.writerTemplate = Just tmpl }
makePDF writerOpts $ appMeta setIsDeFromLang doc
@ -151,8 +156,8 @@ renderLetter rcvrEnt@Entity{entityVal=rcvr} mdl apcIdent = do
--, toMeta "rcvr-email" $ rcvr & userDisplayEmail -- note that some templates use "email" already otherwise
]
e_md <- mdTemplating tmpl meta
result <- actRight e_md $ pdfLaTeX kind
return $ over _Left P.renderError result
actRight e_md $ pdfLaTeX kind
-- return $ over _Left P.renderError result
-- TODO: apcIdent does not make sense for multiple letters
renderLetters :: (MDLetter l, Foldable f) => Entity User -> f l -> Text -> Handler (Either Text LBS.ByteString)
@ -180,8 +185,9 @@ renderLetters rcvrEnt@Entity{entityVal=rcvr} mdls apcIdent
Right doc2 -> pure $ Right $ doc1 <> doc2
doc <- foldrM templateCombine (Right mempty) mdls
result <- actRight doc $ pdfLaTeX kind
return $ over _Left P.renderError result
-- result <- actRight doc $ pdfLaTeX kind
-- return $ over _Left P.renderError result
actRight doc $ pdfLaTeX kind
| otherwise = return $ Left "renderLetters received empty set of letters"
@ -377,7 +383,7 @@ encryptPDF pw bs = over _Left (decodeUtf8 . LBS.toStrict) . exit2either <$> read
-- | Internal only, use `printLetter` instead
lprPDF :: (MonadHandler m, HasAppSettings (HandlerSite m)) => FilePath -> LBS.ByteString -> m (Either Text Text)
lprPDF (sanitizeCmdArg' -> jb) bs = do
mbLprServerArg <- $cachedHereBinary ("lprServer"::Text) getLprServerArg
mbLprServerArg <- getLprServerArg
case mbLprServerArg of
Nothing -> return $ Right "Print command ignored due to setting 'mail-reroute-to' being set."
Just lprServerArg -> do

66
src/Utils/Print/Instances.hs Normal file
View File

@ -0,0 +1,66 @@
-- SPDX-FileCopyrightText: 2022-23 Steffen Jost <jost@tcs.ifi.lmu.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Utils.Print.Instances where
import Import.NoModel
-- import Import
import qualified Text.DocTemplates.Internal as D
import qualified Text.DocLayout as D
import qualified Text.Pandoc as P
-----------------------------
-- Pandoc Orphan Instances --
-----------------------------
-- deriving anyclass instance Generic IOException
-- deriving anyclass instance Binary IOException
-- deriving anyclass instance Binary HttpException
-- deriving anyclass instance Binary P.PandocError
-- required for memcaching compiled markdown and LaTeX templates
instance Binary P.RowHeadColumns
instance Binary P.RowSpan
instance Binary P.ColWidth
instance Binary P.ColSpan
instance Binary P.Alignment
instance Binary P.TableHead
instance Binary P.TableBody
instance Binary P.TableFoot
instance Binary P.MathType
instance Binary P.Cell
instance Binary P.Caption
instance Binary P.Citation
instance Binary P.CitationMode
instance Binary P.ListNumberStyle
instance Binary P.ListNumberDelim
instance Binary P.Format
instance Binary P.QuoteType
instance Binary P.Inline
instance Binary P.Row
instance Binary P.Block
instance Binary P.MetaValue
instance Binary P.Meta
instance Binary P.Pandoc
-- -- and for memchaching a LaTeX template
deriving instance Binary D.Border
deriving instance Binary D.Alignment
deriving instance Binary D.Pipe
deriving instance Binary D.Variable
deriving instance (Binary a) => Binary (D.Doc a)
deriving instance (Binary a) => Binary (P.Template a)
deriving instance NFData D.Border
deriving instance NFData D.Alignment
deriving instance NFData D.Pipe
deriving instance NFData D.Variable
deriving instance (NFData a) => NFData (D.Doc a)
deriving instance (NFData a) => NFData (P.Template a)
-- TODO: sadly this is not yet enough.

2
src/Utils/Print/Letters.hs
View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022 Steffen Jost <jost@tcs.ifi.lmu.de>
-- SPDX-FileCopyrightText: 2022-23 Steffen Jost <jost@tcs.ifi.lmu.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later

2
src/Utils/Users.hs
View File

@ -73,7 +73,7 @@ addNewUser AddUserData{..} = do
, userExamOfficeGetLabels = userDefaultExamOfficeGetLabels
, userNotificationSettings = def
, userLanguages = Nothing
, userCsvOptions = def
, userCsvOptions = def { csvFormat = review csvPreset CsvPresetXlsx }
, userTokensIssuedAfter = Nothing
, userCreated = now
, userLastLdapSynchronisation = Nothing

3
templates/letter/din5008.latex
View File

@ -66,7 +66,8 @@ $endif$
% if luatex or xetex
\usepackage{fontspec}
\setmonofont{DejaVu Sans Mono}
\fi
\fi
\renewcommand{\familydefault}{\sfdefault}
$if(mathspec)$
\ifXeTeX

1
templates/letter/din5008with_pin.latex
View File

@ -67,6 +67,7 @@ $endif$
\usepackage{fontspec}
\setmonofont{DejaVu Sans Mono}
\fi
\renewcommand{\familydefault}{\sfdefault}
$if(mathspec)$
\ifXeTeX

77
templates/letter/fraport_qualification.md
View File

@ -12,11 +12,17 @@ test3: |
<p>Here is some text with <em>emphasis</em> to see.
...
\renewcommand{\familydefault}{\sfdefault}
\vspace*{2cm}
\begin{huge}\sffamily\textbf{%
$if(is-de)$
\medskip
\begin{huge}\sffamily\textbf{Teilnahmebescheinigung}\end{huge}
Teilnahmebescheinigung
$else$
Certificate of attendance
$endif$
}\end{huge}
\vspace{\fill}
@ -27,23 +33,46 @@ $endif$
$if(company)$
## $company$ {-}
$endif$
$if(is-de)$
hat
$if(course-begin)$
$if(course-end)$
von $course-begin$ bis $course-end$
vom $course-begin$ bis zum $course-end$
$else$
am $course-begin$
$endif$
$endif$
an der Veranstaltung
\centerline{\sffamily\LARGE{$course-name$}}
der Fahrerausbildung der Fraport AG teilgenommen.
an der Veranstaltung
$else$
attended
$if(course-begin)$
$if(course-end)$
from $course-begin$ to $course-end$
$else$
on $course-begin$
$endif$
$endif$
the course
$endif$
\vspace*{1.2EX}
\textbf{\LARGE $course-name$}
\vspace*{1.1EX}
$if(is-de)$
der Fahrerausbildung der Fraport AG teilgenommen.
$else$
taught by Fahrerausbildung of Fraport AG.
$endif$
\vspace{\fill}
\vspace{\fill}
$if(course-content)$
## Inhalte: {-}
$if(is-de)$
## Inhalte {-}
$else$
## Course content {-}
$endif$
%%%course-content%%%
@ -51,11 +80,20 @@ $if(course-content)$
$endif$
\vspace{\fill}
\vspace{\fill}
$if(is-de)$
Mit Aushändigung der Teilnahmebescheinigung wird der erfolgreiche Abschluss des Kurses bestätigt.
Dieses Zertifikat wurde maschinell erstellt.
Dieses Zertifikat wurde maschinell erstellt.
$else$
The successful completion of the course is confirmed
by handing out this certificate.
This is machine generated certificate requires no signature.
$endif$
\medskip
@ -65,20 +103,5 @@ Fraport College
\vspace{\fill}
\vspace{\fill}
\vspace{\fill}
\vspace{\fill}
\vspace{\fill}
<!-- deutsche version -->
$else$
<!-- english version -->
# Certificate of attendance
**English version is not yet implemened.**
TODO
$endif$
\clearpage

10
templates/letter/plain_article.latex
View File

@ -51,15 +51,19 @@ $endif$
\fi
\ifPDFTeX
\usepackage{helvet}
\usepackage[$if(fontenc)$$fontenc$$else$T1$endif$]{fontenc}
\usepackage[utf8]{inputenc}
\usepackage{textcomp} % provide euro and other symbols
\usepackage{DejaVuSansMono} % better monofont
\usepackage{textcomp}% provide euro and other symbols
\usepackage{DejaVuSansMono}% better monofont
\renewcommand{\familydefault}{\sfdefault}
\else
% if luatex or xetex
\usepackage{fontspec}
%\setmainfont{TeXGyreHeros}%could not install the package somehow tex-gyre in default.nix/shell.nix did not work
\setmainfont{DejaVu Sans}
\setmonofont{DejaVu Sans Mono}
%\renewcommand{\familydefault}{\sfdefault}
\renewcommand{\familydefault}{\sfdefault}
\fi
$if(mathspec)$

2
templates/mail/qualificationExpired.hamlet
View File

@ -29,7 +29,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
#{qualificationName}
<dt>_{SomeMessage MsgLmsUser}
<dd>#{nameHtml userDisplayName userSurname}
<dt>_{SomeMessage MsgLmsQualificationValidUntil}
<dt>_{SomeMessage MsgQualificationExpired}
<dd>#{expiryDate}

2
templates/widgets/form/form.hamlet
View File

@ -5,7 +5,7 @@ $#
$# SPDX-License-Identifier: AGPL-3.0-or-later
$# Wrapper for all kinds of forms
<form ##{formId} method=#{decodeUtf8 (renderStdMethod formMethod)} action=#{fromMaybe "" formActionUrl} enctype=#{formEncoding} *{formAttrs}>
<form ##{formId} method=#{decodeUtf8 (renderStdMethod formMethod)} :hasAction:action=#{fromMaybe "" formActionUrl} enctype=#{formEncoding} *{formAttrs}>
$# Distinguish different falvours of submit button layouts here:
$case formSubmit
$of FormNoSubmit

8
test/Database/Fill.hs
View File

@ -163,7 +163,7 @@ fillDb = do
, userAuthentication = pwSimple
, userLastAuthentication = Nothing
, userTokensIssuedAfter = Nothing
, userMatrikelnummer = Just "94094094094"
, userMatrikelnummer = Just "12345678"
, userEmail = "S.Jost@Fraport.de"
, userDisplayEmail = "jost@tcs.ifi.lmu.de"
, userDisplayName = "Steffen Jost"
@ -680,6 +680,10 @@ fillDb = do
void . insert' $ UserAvs (AvsPersonId 4) sbarth 4
void . insert' $ UserAvs (AvsPersonId 5) fhamann 5
void . insert' $ UserAvs (AvsPersonId 77) tinaTester 77
void . insert' $ UserAvsCard (AvsPersonId 12345678) (AvsFullCardNo (AvsCardNo "1234") "4") (AvsDataPersonCard True Nothing Nothing AvsCardColorGelb (Set.fromList ['F']) Nothing Nothing Nothing Nothing (AvsCardNo "1234") "4") now
void . insert' $ UserAvsCard (AvsPersonId 2) (AvsFullCardNo (AvsCardNo "3344") "1") (AvsDataPersonCard True Nothing Nothing AvsCardColorRot (Set.fromList ['F','R']) Nothing Nothing Nothing Nothing (AvsCardNo "3344") "1") now
void . insert' $ UserAvsCard (AvsPersonId 3) (AvsFullCardNo (AvsCardNo "7788") "1") (AvsDataPersonCard False Nothing Nothing AvsCardColorRot (Set.fromList ['F','R']) Nothing Nothing Nothing Nothing (AvsCardNo "7788") "1") now
void . insert' $ UserAvsCard (AvsPersonId 4) (AvsFullCardNo (AvsCardNo "9999") "4") (AvsDataPersonCard True Nothing Nothing AvsCardColorGelb (Set.fromList ['F']) Nothing Nothing Nothing Nothing (AvsCardNo "9999") "4") now
let f_descr = Just $ htmlToStoredMarkup [shamlet|<p>Berechtigung zum Führen eines Fahrzeuges auf den Fahrstrassen des Vorfeldes.|]
let r_descr = Just $ htmlToStoredMarkup [shamlet|<p>Berechtigung zum Führen eines Fahrzeuges auf dem gesamten Rollfeld.|]
@ -932,7 +936,7 @@ fillDb = do
<section>
<h3>Benötigte Unterlagen
<ul>
<li>Sehtest,
<li>Sehtest, #
<i>bitte vorab hochladen!
<li>Regulärer Führerschein,
<i>Bitte mitbringen.