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

Merge branch 'master' into srv01

Browse Source
This commit is contained in:
Sarah Vaupel 2023-05-05 12:38:41 +00:00
commit e25af0d25a
67 changed files with 1104 additions and 463 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

30
CHANGELOG.md
View File

@ -2,6 +2,36 @@
All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines.
## [27.3.2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.3.1...v27.3.2) (2023-05-05)
### Bug Fixes
* **build:** remove impossible ([90b38ca](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/90b38ca5dc319f2d175978242b2fdd4477568a3c))
## [27.3.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.3.0...v27.3.1) (2023-05-04)
## [27.3.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.2.0...v27.3.0) (2023-05-02)
### Features
* **qualfications:** renewal actions and filtering by card and personal number ([4df0243](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/4df024374d387fc85a833b3faffe1b6ef8edc7d9))
### Bug Fixes
* **avs:** chunk avs status query automatically ([352ee21](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/352ee215b4075c70dbf9229434e62c8e6d847ae4))
* **build:** minor move parenthesis to make linter happy ([02bf1d9](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/02bf1d9a2ca433e55cf7d1e06f0ff300b53c7efb))
* **build:** remove redundant constraints ([ea82d75](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/ea82d75a0934f8e13f26af5cb8a06c11d32dc0c5))
* **cvs:** export company in e-learning view ([2093cf5](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/2093cf501827ab2305f26ab5cf742f2b0be4a7de))
* **email:** better wording for qualifcation expired notice ([412c56e](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/412c56e78ceaef263e4ca8b8678bb0e8ea2efb9a))
* **letter:** update receiver postal address before sending ([7d5c4bf](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/7d5c4bff2512154c087133e029713efa0657fa5a))
* **profile:** bad email indicator ([6699f1d](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/6699f1d72f148ccd2c82bebb3f582cf61d711425))
* **qualifications:** counts for lms/quals correct now ([33a847b](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/33a847baa3310e6e261409f2cda9d964cf5a821d))
* **users:** assimilate merges possibly incomplete user fields ([52afd13](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/52afd13b6dc2b870ab8dbba956874e8950e07973))
* **users:** prevent accidental user hijacking ([014d479](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/014d479df8f36515915bc7991bb97bad24dcbef9))
## [27.2.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.1.6...v27.2.0) (2023-04-06)

2
build.sh
View File

@ -9,5 +9,5 @@ set -e
[ "${FLOCKER}" != "$0" ] && exec env FLOCKER="$0" flock -en .stack-work.lock "$0" "$@" || :
echo "Building..."
stack build --fast --flag uniworx:-library-only --flag uniworx:dev $@
stack build --fast --profile --library-profiling --executable-profiling --flag uniworx:-library-only --flag uniworx:dev $@
echo "Done."

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

4
messages/uniworx/categories/courses/tutorial/en-eu.msg
View File

@ -46,8 +46,8 @@ TutorialUsersDeregistered count: Successfully deregistered #{show count} partici
TutorialUserDeregister: Deregister from tutorial
TutorialUserSendMail: Send mail
TutorialUserPrintQualification: Print certificate
TutorialUserGrantQualification: Grant Qualification
TutorialUserRenewQualification: Renew Qualification
TutorialUserGrantQualification: Grant qualification
TutorialUserRenewQualification: Renew qualification
TutorialUserRenewedQualification n@Int: Successfully renewed qualification #{tshow n} tutorial #{pluralEN n "user" "users"}
TutorialUserGrantedQualification n: Successfully granted qualification #{tshow n} tutorial #{pluralEN n "user" "users"}
CommTutorial: Tutorial message

6
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,11 @@ 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
QualificationActGrant: Qualifikation vergeben
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.

12
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
@ -63,13 +65,13 @@ CsvColumnLmsDelete: Will the identifier be deleted from the E-learning platfrom
CsvColumnLmsStaff: Is the user an internal staff member? (Legacy, currently ignored)
CsvColumnLmsSuccess: Timestamp of successful completion (UTC)
CsvColumnLmsFailed: Blockier durch LMS, üblicherweise wegen zu vieler Fehlversuche
LmsUserlistInsert: New LMS User
LmsUserlistUpdate: Update of LMS User
LmsUserlistInsert: New LMS user
LmsUserlistUpdate: Update of LMS user
LmsResultInsert: New LMS result
LmsResultUpdate: Update of LMS result
LmsResultCsvExceptionDuplicatedKey: CSV import with ambiguous key
LmsUserlistCsvExceptionDuplicatedKey: CSV import with ambiguous key
LmsDirectUpload: Direct upload for automated Systems
LmsDirectUpload: Direct upload for automated systems
LmsErrorNoRefreshElearning: Error: E-learning will not be started automatically due to refresh-within time period not being set.
MailSubjectQualificationRenewal qname: Qualification #{qname} must be renewed shortly
MailSubjectQualificationExpiry qname: Qualification #{qname} expires soon
@ -81,9 +83,11 @@ 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
QualificationActGrant: Grant qualification
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/avs.model
View File

@ -29,5 +29,5 @@ UserAvsCard
cardNo AvsFullCardNo
card AvsDataPersonCard
lastSynch UTCTime
UniqueAvsCard cardNo
-- UniqueAvsCard cardNo -- Note: cardNo is not unique; invalid cardNo may be reissued to different persons
deriving Generic

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
nix/docker/demo-version.json
View File

@ -1,3 +1,3 @@
{
"version": "27.2.0"
"version": "27.3.2"
}

2
nix/docker/version.json
View File

@ -1,3 +1,3 @@
{
"version": "27.2.0"
"version": "27.3.2"
}

2
package-lock.json generated
View File

@ -1,6 +1,6 @@
{
"name": "uni2work",
"version": "27.2.0",
"version": "27.3.2",
"lockfileVersion": 1,
"requires": true,
"dependencies": {

2
package.json
View File

@ -1,6 +1,6 @@
{
"name": "uni2work",
"version": "27.2.0",
"version": "27.3.2",
"description": "",
"keywords": [],
"author": "",

5
package.yaml
View File

@ -1,5 +1,5 @@
name: uniworx
version: 27.2.0
version: 27.3.2
dependencies:
- base
- yesod
@ -147,6 +147,8 @@ dependencies:
- extended-reals
- rfc5051
- unidecode
- doctemplates
- doclayout
- pandoc
- pandoc-types
- typed-process
@ -256,6 +258,7 @@ ghc-options:
- -fno-max-relevant-binds
- -j
- -freduction-depth=0
- -fprof-auto-calls
when:
- condition: flag(pedantic)
ghc-options:

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

3
src/Handler/Admin/Test.hs
View File

@ -14,6 +14,7 @@ import Utils.Print
import Handler.Utils
import Jobs
import Data.Ratio ((%))
import Data.Char (isDigit)
import qualified Data.Text as Text
-- import qualified Data.Text.IO as Text
@ -97,7 +98,7 @@ postAdminTestR = do
case btnResult of
(FormSuccess CreateInf) -> addMessage Info "Informatik-Knopf gedrückt"
(FormSuccess CreateMath) -> addMessage Warning "Knopf Mathematik erkannt"
(FormSuccess CrashApp) -> addMessage Error "Crash Button betätigt" >> error "Crash Button"
(FormSuccess CrashApp) -> addMessage Error "Crash Button Ratio 0 betätigt" >> error ("Crash Button" <> show (1 % 0))
FormMissing -> return ()
_other -> addMessage Warning "KEIN Knopf erkannt"

7
src/Handler/Health.hs
View File

@ -17,6 +17,8 @@ import qualified Data.Set as Set
import Control.Concurrent.STM.Delay
import System.Environment (lookupEnv) -- while git version number is not working
-- import Data.FileEmbed (embedStringFile)
getHealthR :: Handler TypedContent
@ -107,7 +109,7 @@ getInstanceR = do
getStatusR :: Handler Html
getStatusR = do
starttime <- getsYesod appStartTime
currtime <- liftIO getCurrentTime
(currtime, env_version) <- liftIO $ (,) <$> getCurrentTime <*> lookupEnv "VERSION_NR"
-- ft <- formatTime' "%Y-%m-%d %H:%M:%S" currtime
withUrlRenderer
[hamlet|
@ -116,6 +118,9 @@ getStatusR = do
<head>
<title>Status
<body>
$maybe env_ver <- env_version
<p>
Environment version #{env_ver}
<p>
Current Time <br>
#{show currtime} <br>

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 $ \(queryUser -> user) (criterion :: Set.Set Text) -> case readAvsFullCardNo =<< Set.lookupMin criterion of
Nothing -> E.false
Just cardNo -> E.exists $ E.from $ \(avsCard `E.InnerJoin` usrAvs) -> do
E.on $ usrAvs E.^. UserAvsPersonId E.==. avsCard E.^. UserAvsCardPersonId
E.where_ $ usrAvs E.^. UserAvsUser E.==. user E.^. UserId
E.&&. (avsCard E.^. UserAvsCardCardNo E.==. E.val cardNo)
)
, 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
}

67
src/Handler/PrintCenter.hs
View File

@ -2,7 +2,7 @@
--
-- SPDX-License-Identifier: AGPL-3.0-or-later
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeApplications, ExistentialQuantification #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Handler.PrintCenter
@ -25,6 +25,8 @@ import qualified Database.Esqueleto.Utils as E
import Database.Esqueleto.Utils.TH
import Utils.Print
import Utils.Print.Letters (MDLetter)
-- import Data.Aeson (encode)
import qualified Data.Text as Text
-- import qualified Data.Set as Set
@ -37,20 +39,24 @@ import Handler.Utils
single :: (k,a) -> Map k a
single = uncurry Map.singleton
data SomeLetter = forall l . (MDLetter l) => SomeLetter l -- a record selector would be useless here due to the escaped type variable
data LRQF = LRQF
{ lrqfUser :: Either UserEmail UserId
, lrqfSuper :: Maybe (Either UserEmail UserId)
, lrqfQuali :: Entity Qualification
, lrqfIdent :: LmsIdent
, lrqfPin :: Text
, lrqfExpiry:: Day
{ lrqfLetter :: Text
, lrqfUser :: Either UserEmail UserId
, lrqfSuper :: Maybe (Either UserEmail UserId)
, lrqfQuali :: Entity Qualification
, lrqfIdent :: LmsIdent
, lrqfPin :: Text
, lrqfExpiry :: Day
} deriving (Eq, Generic)
makeRenewalForm :: Maybe LRQF -> Form LRQF
makeRenewalForm tmpl = identifyForm FIDLmsLetter . validateForm validateLetterRenewQualificationF $ \html -> do
-- now_day <- utctDay <$> liftIO getCurrentTime
flip (renderAForm FormStandard) html $ LRQF
<$> areq (userField False Nothing) (fslI MsgLmsUser) (lrqfUser <$> tmpl)
<$> areq textField (fslI MsgLmsUser) (lrqfLetter <$> tmpl)
<*> areq (userField False Nothing) (fslI MsgLmsUser) (lrqfUser <$> tmpl)
<*> aopt (userField False Nothing) (fslI MsgTableSupervisor) (lrqfSuper <$> tmpl)
<*> areq qualificationFieldEnt (fslI MsgQualificationName) (lrqfQuali <$> tmpl)
<*> areq lmsField (fslI MsgTableLmsIdent) (lrqfIdent <$> tmpl)
@ -64,8 +70,9 @@ validateLetterRenewQualificationF = -- do
-- LRQF{..} <- State.get
return ()
lrqf2letter :: LRQF -> DB (Entity User, LetterRenewQualificationF)
lrqf2letter LRQF{..} = do
lrqf2letter :: LRQF -> DB (Entity User, SomeLetter)
lrqf2letter LRQF{..}
| lrqfLetter == "r" = do
usr <- getUser lrqfUser
rcvr <- mapM getUser lrqfSuper
let letter = LetterRenewQualificationF
@ -81,7 +88,24 @@ lrqf2letter LRQF{..} = do
, qualSchool = lrqfQuali ^. _qualificationSchool
, qualDuration = lrqfQuali ^. _qualificationValidDuration
}
return (fromMaybe usr rcvr, letter)
return (fromMaybe usr rcvr, SomeLetter letter)
| lrqfLetter == "e" = do
rcvr <- mapM getUser lrqfSuper
usr <- getUser lrqfUser
usrUuid <- encrypt $ entityKey usr
let letter = LetterExpireQualificationF
{ leqfHolderUUID = usrUuid
, leqfHolderID = usr ^. _entityKey
, leqfHolderDN = usr ^. _userDisplayName
, leqfHolderSN = usr ^. _userSurname
, leqfExpiry = lrqfExpiry
, leqfId = lrqfQuali ^. _entityKey
, leqfName = lrqfQuali ^. _qualificationName . _CI
, leqfShort = lrqfQuali ^. _qualificationShorthand . _CI
, leqfSchool = lrqfQuali ^. _qualificationSchool
}
return (fromMaybe usr rcvr, SomeLetter letter)
| otherwise = error "Unknown Letter Type encountered. Use 'e' or 'r' only."
where
getUser :: Either UserEmail UserId -> DB (Entity User)
getUser (Right uid) = getEntity404 uid
@ -157,12 +181,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
@ -176,7 +199,7 @@ mkPJTable = do
, sortable (Just "sender") (i18nCell MsgPrintSender) $ \(preview resultSender -> u) -> maybeCell u $ cellHasUserLink AdminUserR
, sortable (Just "course") (i18nCell MsgPrintCourse) $ \(preview $ resultCourse . _entityVal -> c) -> maybeCell c courseCell
, sortable (Just "qualification")(i18nCell MsgPrintQualification) $ \(preview $ resultQualification . _entityVal -> q) -> maybeCell q qualificationCell
, sortable (Just "lmsid") (i18nCell MsgPrintLmsUser) $ \( view $ resultPrintJob . _entityVal . _printJobLmsUser -> l) -> foldMap textCell (getLmsIdent <$> l)
, sortable (Just "lmsid") (i18nCell MsgPrintLmsUser) $ \( view $ resultPrintJob . _entityVal . _printJobLmsUser -> l) -> foldMap (textCell . getLmsIdent) l
]
dbtSorting = mconcat
[ single ("name" , SortColumn $ queryPrintJob >>> (E.^. PrintJobName))
@ -227,7 +250,7 @@ mkPJTable = do
dbtExtraReps = []
dbtParams = DBParamsForm
{ dbParamsFormMethod = POST
, dbParamsFormAction = Just $ SomeRoute currentRoute
, dbParamsFormAction = Nothing -- Just $ SomeRoute currentRoute
, dbParamsFormAttrs = []
, dbParamsFormSubmit = FormSubmit
, dbParamsFormAdditional
@ -254,8 +277,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 +285,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
@ -279,7 +301,8 @@ postPrintSendR = do
let nowaday = utctDay now
uid = usr ^. _entityKey
mkLetter qual = LRQF
{ lrqfUser = Right uid
{ lrqfLetter = "r"
, lrqfUser = Right uid
, lrqfSuper = Nothing
, lrqfQuali = qual
, lrqfIdent = LmsIdent "stuvwxyz"
@ -290,7 +313,9 @@ postPrintSendR = do
((sendResult, sendWidget), sendEnctype) <- runFormPost $ makeRenewalForm def_lrqf
let procFormSend lrqf = do
ok <- (runDB (lrqf2letter lrqf) >>= printLetter (Just uid)) >>= \case
ok <- (runDB (lrqf2letter lrqf) >>= \case
(entUsr, SomeLetter l) -> printLetter (Just uid) (entUsr, l)
) >>= \case
Left err -> do
let msg = "PDF printing failed with error: " <> err
$logErrorS "LPR" msg

240
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,32 @@ data QualificationTableAction
| QualificationActBlockSupervisor
| QualificationActBlock
| QualificationActUnblock
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
| QualificationActRenew
| QualificationActGrant
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
| QualificationActGrantData { qualTableActGrantUntil :: Day }
deriving (Eq, Ord, Read, Show, Generic)
isExpiryAct :: QualificationTableActionData -> Bool
isExpiryAct QualificationActExpireData = True
@ -284,18 +301,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 +323,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 +345,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,6 +360,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 ("avs-card" , FilterColumn $ \(queryUser -> user) (criterion :: Set.Set Text) -> case readAvsFullCardNo =<< Set.lookupMin criterion of
Nothing -> E.false
Just cardNo -> E.exists $ E.from $ \(avsCard `E.InnerJoin` usrAvs) -> do
E.on $ usrAvs E.^. UserAvsPersonId E.==. avsCard E.^. UserAvsCardPersonId
E.where_ $ usrAvs E.^. UserAvsUser E.==. user E.^. UserId
E.&&. (avsCard E.^. UserAvsCardCardNo E.==. E.val cardNo)
)
, 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 ("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`
@ -351,8 +390,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 +413,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 +442,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,38 +468,48 @@ 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
now <- liftIO getCurrentTime
let nowaday = utctDay now
((lmsRes, qualificationTable), Entity qid quali) <- runDB $ do
qent@Entity{entityVal=Qualification{qualificationAuditDuration=auditMonths}} <- getBy404 $ SchoolQualificationShort sid qsh
let acts :: Map QualificationTableAction (AForm Handler QualificationTableActionData)
qent@Entity{entityVal=Qualification{
qualificationAuditDuration=auditMonths
, qualificationValidDuration=validMonths
}} <- getBy404 $ SchoolQualificationShort sid qsh
let dayExpiry = flip addGregorianDurationClip nowaday . fromMonths <$> validMonths
acts :: Map QualificationTableAction (AForm Handler QualificationTableActionData)
acts = mconcat $
[ 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
, singletonMap QualificationActGrant
(QualificationActGrantData <$> apopt dayField (fslI MsgLmsQualificationValidUntil) dayExpiry)
] 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 +526,15 @@ 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
(QualificationActGrantData grantValidday, selectedUsers) | isAdmin -> do
runDB . forM_ selectedUsers $ upsertQualificationUser qid nowaday grantValidday Nothing
addMessageI (if 0 < Set.size selectedUsers then Success else Warning) . MsgTutorialUserGrantedQualification $ Set.size selectedUsers
reloadKeepGetParams $ QualificationR sid qsh
(action, selectedUsers) | isExpiryAct action -> do
let isUnexpire = action == QualificationActUnexpireData
upd <- runDB $ updateWhereCount
@ -476,10 +543,9 @@ 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
(action, selectedUsers) | isBlockAct action && (isAdmin || action == QualificationActBlockSupervisorData) -> do
now <- liftIO getCurrentTime
let nowaday = utctDay now
reloadKeepGetParams $ QualificationR sid qsh
(action, selectedUsers) | isBlockAct action && (isAdmin || action == QualificationActBlockSupervisorData) -> do
let selUserIds = Set.toList selectedUsers
qubr = case action of
QualificationActUnblockData -> Nothing
QualificationActBlockSupervisorData -> Just $ mkQualificationBlocked QualificationBlockReturnedByCompany nowaday
@ -488,7 +554,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 +568,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
}

2
src/Handler/Tutorial/Users.hs
View File

@ -66,7 +66,7 @@ postTUsersR tid ssh csh tutn = do
tutEnt@(Entity tutid _) <- fetchTutorial tid ssh csh tutn
qualifications <- getCourseQualifications cid
now <- liftIO getCurrentTime
let minDur :: Maybe Int = minimumMaybe $ catMaybes (view _qualificationValidDuration <$> qualifications) -- no instance Ord CalendarDiffDays
let minDur :: Maybe Int = minimumMaybe $ mapMaybe (view _qualificationValidDuration) qualifications -- no instance Ord CalendarDiffDays
dayExpiry = flip addGregorianDurationClip (utctDay now) . fromMonths <$> minDur
colChoices = mconcat $ catMaybes
[ pure $ dbSelect (applying _2) id (return . view (hasEntity . _entityKey))

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)

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

@ -339,12 +339,16 @@ guessAvsUser (Text.splitAt 6 -> ("AVSNO:", avsnoTxt)) = ifMaybeM (readMay avsnoT
_ -> return Nothing
guessAvsUser someid = do
let maybeUpsertAvsUserByCard = maybeCatchAll . upsertAvsUserByCard
extractUid (Entity _ UserAvs{userAvsUser=uid}) = return $ Just uid
extractUidCard (Entity _ UserAvsCard{userAvsCardPersonId=avid}) = getBy $ UniqueUserAvsId avid
case discernAvsCardPersonalNo someid of
Just cid@(Left cardNo) ->
maybeM (maybeUpsertAvsUserByCard cid) extractUid $ runDB $
maybeM (return Nothing) extractUidCard $ getBy $ UniqueAvsCard cardNo
Just cid@(Left _cardNo) -> maybeUpsertAvsUserByCard cid
-- NOTE: card validity might be outdated, so we must always check with avs
-- maybeM (maybeUpsertAvsUserByCard cid) extractUid $ runDB $ do
-- let extractUid (Entity _ UserAvs{userAvsUser=uid}) = return $ Just uid
-- extractUidCard UserAvsCard{userAvsCardPersonId=avid} = getBy $ UniqueUserAvsId avid
-- cards <- selectList [UserAvsCardCardNo ==. cardNo] []
-- case [c | cent <- cards, let c = entityVal cent, avsDataValid (userAvsCardCard c)] of
-- [justOneCard] -> maybeM (return Nothing) extractUidCard (return $ Just justOneCard)
-- _ -> return Nothing
Just cid@(Right _wholeNumber) ->
maybeUpsertAvsUserByCard cid >>= \case
Nothing ->
@ -493,15 +497,16 @@ upsertAvsUserById api = do
[UserPinPassword =. userPin]
insert_ $ UserAvsCard api (getFullCardNo pCard) pCard now
upsertUserCompany uid mbCompany userFirmAddr
forM_ avsPersonPersonCards $ \aCard -> void $ upsert UserAvsCard
forM_ avsPersonPersonCards $ \aCard -> do
let fcn = getFullCardNo aCard
-- probably not efficient, but fixes the problem that AvsCardNo is not unique as assumed before and may get reused
deleteWhere [UserAvsCardCardNo ==. fcn]
insert_ $ UserAvsCard
{ userAvsCardPersonId = api
, userAvsCardCardNo = getFullCardNo aCard
, userAvsCardCardNo = fcn
, userAvsCardCard = aCard
, userAvsCardLastSynch = now
}
[ UserAvsCardCard =. aCard
, UserAvsCardLastSynch =. now
]
return $ Just uid

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 }

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

@ -137,4 +137,35 @@ qualificationUserBlocking qid uids qb = do
, transactionUser = uid
, transactionQualificationBlock = qb
}
return $ fromIntegral oks
qualificationUserUnblockByReason ::
( AuthId (HandlerSite m) ~ Key User
, IsPersistBackend (YesodPersistBackend (HandlerSite m))
, BaseBackend (YesodPersistBackend (HandlerSite m)) ~ SqlBackend
, BackendCompatible SqlBackend (YesodPersistBackend (HandlerSite m))
, PersistQueryWrite (YesodPersistBackend (HandlerSite m))
, PersistUniqueWrite (YesodPersistBackend (HandlerSite m))
, HasInstanceID (HandlerSite m) InstanceId
, YesodAuthPersist (HandlerSite m)
, HasAppSettings (HandlerSite m)
, MonadHandler m
, MonadCatch m
, Num n
) => QualificationId -> [UserId] -> Text -> ReaderT (YesodPersistBackend (HandlerSite m)) m n
qualificationUserUnblockByReason qid uids reason = do
blockedUsers <- selectList [ QualificationUserQualification ==. qid
, QualificationUserBlockedDue !=. Nothing
, QualificationUserUser <-. uids
] [Asc QualificationUserId]
let toUnblock = filter (\quent -> Just reason == quent ^? _entityVal . _qualificationUserBlockedDue . _Just . _qualificationBlockedReason) blockedUsers
oks <- updateWhereCount [ QualificationUserId <-. (view _entityKey <$> toUnblock) ]
[ QualificationUserBlockedDue =. Nothing ]
forM_ toUnblock $ \ubl -> do
audit TransactionQualificationUserBlocking
{ -- transactionQualificationUser = quid
transactionQualification = qid
, transactionUser = ubl ^. _entityVal . _qualificationUserUser
, transactionQualificationBlock = Nothing
}
return $ fromIntegral oks

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) ()

13
src/Jobs/Handler/LMS.hs
View File

@ -217,7 +217,7 @@ dispatchJobLmsResults qid = JobHandlerAtomic act
return (quser, luser, lresult)
now <- liftIO getCurrentTime
let locDay = localDay $ TZ.utcToLocalTimeTZ appTZ now
forM_ results $ \(Entity _quid QualificationUser{..}, Entity luid LmsUser{..}, Entity lrid LmsResult{..}) -> do
forM_ results $ \(Entity quid QualificationUser{..}, Entity luid LmsUser{..}, Entity lrid LmsResult{..}) -> do
-- three separate DB operations per result is not so nice. All within one transaction though.
let lmsUserStartedDay = localDay $ TZ.utcToLocalTimeTZ appTZ lmsUserStarted
saneDate = lmsResultSuccess `inBetween` (lmsUserStartedDay, min qualificationUserValidUntil locDay)
@ -226,15 +226,18 @@ dispatchJobLmsResults qid = JobHandlerAtomic act
-- newValidTo = addGregorianMonthsRollOver (toInteger renewalMonths) qualificationUserValidUntil -- renew from old validUntil onwards
note <- if saneDate && replaceLmsStatus lmsUserStatus newStatus
then do
_ok <- renewValidQualificationUsers qid [qualificationUserUser] -- blocked remains unaffected
_ok <- renewValidQualificationUsers qid [qualificationUserUser] -- ignores possible blocks
-- when (ok==1) $ update luid -- we end lms regardless of wether a regular renewal was successful, since BPol users may simultaneoysly have on-premise renewal courses and E-Learnings
-- WORKAROUND LMS-Bug [supposedly fixed now, but isnt]: sometimes we receive success and failure simultaneously; success is correct, hence we must unblock if the reason was e-learning
-- _ok <- qualificationUserUnblockByReason qid [qualificationUserUser] (qualificationBlockedReasonText QualificationBlockFailedELearning) -- affects audit log
when (Just (qualificationBlockedReasonText QualificationBlockFailedELearning) == qualificationUserBlockedDue ^? _Just . _qualificationBlockedReason) $
update quid [ QualificationUserBlockedDue =. Nothing ]
update luid
[ LmsUserStatus =. newStatus
, LmsUserReceived =. Just lmsResultTimestamp
]
-- WORKAROUND LMS-Bug [supposedly fixed now]: sometimes we receive success and failure simultaneously; success is correct, hence we must unblock if the reason was e-learning
-- when (Just (qualificationBlockedReasonText QualificationBlockFailedELearning) == qUsr ^? _qualificationUserBlockedDue . _Just . _qualificationBlockedReason) $
-- update quid [ QualificationUserBlockedDue =. Nothing ]
return Nothing
else do
let errmsg = [st|LMS success with insane date #{tshow lmsResultSuccess} received for #{tshow lmsUserIdent}|]

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

45
src/Utils/Avs.hs
View File

@ -32,10 +32,10 @@ type AVSGetRampLicences = "RampDrivingLicenceInfo" :> ReqBody '[JSON] AvsQueryG
type AVSSetRampLicences = "RampDrivingLicence" :> ReqBody '[JSON] AvsQuerySetLicences :> Post '[JSON] AvsResponseSetLicences
avsMaxSetLicenceAtOnce :: Int
avsMaxSetLicenceAtOnce = 90 -- maximum input set size for avsQuerySetLicences as enforced by AVS
avsMaxSetLicenceAtOnce = 80 -- 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 = 500 -- 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,18 @@ 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
| avsMaxQueryAtOnce >= Set.size s = rawQuery q
| otherwise = do
-- $logInfoS "AVS" $ "Splitting large query for input Set " <> tshow (Set.size s) -- would require MonadLogger ClientM
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)

44
src/Utils/Print.hs
View File

@ -16,8 +16,11 @@ module Utils.Print
-- , compileTemplate, makePDF
, _Meta, addMeta
, toMeta, mbMeta -- single values
, mkMeta, appMeta, applyMetas -- multiple values
, mkMeta, appMeta, applyMetas -- multiple values
-- , MDMail
-- , MDLetter
, LetterRenewQualificationF(..)
, LetterExpireQualificationF(..)
-- , LetterCourseCertificate()
, makeCourseCertificates
) where
@ -42,6 +45,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,8 +53,10 @@ 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.ExpireQualification
import Utils.Print.CourseCertificate
@ -108,31 +114,34 @@ 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
md_txt <- P.writeMarkdown writerOpts $ appMeta setIsDeFromLang $ addMeta meta doc
P.readMarkdown readerOpts md_txt
ExceptT . pure . over _Left P.renderError . P.runPure $ do
md_txt <- P.writeMarkdown writerOpts $ appMeta setIsDeFromLang $ addMeta meta doc
addMeta meta <$> P.readMarkdown readerOpts md_txt -- NOTE: meta is lost along the way somehow, despite P.pandocExtensions containing Ext_yaml_metadata_block
-- | 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
renderLetter :: (MDLetter l) => Entity User -> l -> Text -> Handler (Either Text LBS.ByteString)
renderLetter rcvrEnt@Entity{entityVal=rcvr} mdl apcIdent = do
@ -151,8 +160,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
-- 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 +189,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 +387,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

84
src/Utils/Print/ExpireQualification.hs Normal file
View File

@ -0,0 +1,84 @@
-- SPDX-FileCopyrightText: 2023 Steffen Jost <jost@tcs.ifi.lmu.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later
{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
module Utils.Print.ExpireQualification where
import Import
import Text.Hamlet
-- import Data.Char as Char
-- import qualified Data.Text as Text
import qualified Data.CaseInsensitive as CI
import Data.FileEmbed (embedFile)
import Utils.Print.Letters
import Handler.Utils.Widgets (nameHtml) -- , nameHtml')
data LetterExpireQualificationF = LetterExpireQualificationF
{ leqfHolderUUID:: CryptoUUIDUser
, leqfHolderID :: UserId
, leqfHolderDN :: UserDisplayName
, leqfHolderSN :: UserSurname
, leqfExpiry :: Day
, leqfId :: QualificationId
, leqfName :: Text
, leqfShort :: Text
, leqfSchool :: SchoolId
}
deriving (Eq, Show)
-- TODO: use markdown to generate the Letter
instance MDMail LetterExpireQualificationF where
getMailSubject l = SomeMessage $ MsgMailSubjectQualificationExpired $ leqfShort l
getMailBody LetterExpireQualificationF{..} DateTimeFormatter{ format } =
let expiryDate = format SelFormatDate leqfExpiry
userDisplayName = leqfHolderDN
userSurname = leqfHolderSN
qualificationName = leqfName
qualificationShorthand = CI.mk leqfShort
qualificationSchool = leqfSchool
qname = qualificationName
ihamletSomeMessage _ _ _ = (mempty :: Html) -- TODO: use markdown for letter
editNotifications = () -- TODO: use markdown for letter
in $(ihamletFile "templates/mail/qualificationExpired.hamlet")
instance MDLetter LetterExpireQualificationF where
encrypPDFfor _ = NoPassword
getLetterKind _ = Din5008
getLetterEnvelope _ = 'e'
getTemplate _ = decodeUtf8 $(Data.FileEmbed.embedFile "templates/letter/fraport_f_expiry.md")
letterMeta LetterExpireQualificationF{..} DateTimeFormatter{ format } lang Entity{entityKey=rcvrId, entityVal=User{userDisplayName}} =
let isSupervised = rcvrId /= leqfHolderID
in mkMeta $
guardMonoid isSupervised
[ toMeta "supervisor" userDisplayName
, toMeta "de-opening" ("Sehr geehrte Damen und Herren,"::Text)
, toMeta "en-opening" ("Dear Sir or Madam,"::Text)
] <>
[ toMeta "lang" lang
, toMeta "licenceholder" leqfHolderDN
, toMeta "expiry" (format SelFormatDate leqfExpiry)
]
getPJId LetterExpireQualificationF{..} =
PrintJobIdentification
{ pjiName = "Expiry"
, pjiApcAcknowledge = "exp-" <> tshow (ciphertext leqfHolderUUID)
, pjiRecipient = Nothing -- to be filled later
, pjiSender = Nothing
, pjiCourse = Nothing
, pjiQualification = Just leqfId
, pjiLmsUser = Nothing
, pjiFileName = "expire_" <> CI.original (unSchoolKey leqfSchool) <> "-" <> leqfShort <> "_" <> leqfHolderSN
-- let nameRecipient = abbrvName <$> recipient
-- nameSender = abbrvName <$> sender
-- nameCourse = CI.original . courseShorthand <$> course
-- nameQuali = CI.original . qualificationShorthand <$> quali
-- in .. = T.replace " " "-" (T.intercalate "_" . catMaybes $ [Just printJobName, nameQuali, nameCourse, nameSender, nameRecipient])
}

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

6
src/Utils/Print/RenewQualification.hs
View File

@ -9,8 +9,8 @@ module Utils.Print.RenewQualification where
import Import
import Text.Hamlet
import Data.Char as Char
import qualified Data.Text as Text
-- import Data.Char as Char
-- import qualified Data.Text as Text
import qualified Data.CaseInsensitive as CI
import Data.FileEmbed (embedFile)
@ -55,7 +55,7 @@ instance MDMail LetterRenewQualificationF where
instance MDLetter LetterRenewQualificationF where
encrypPDFfor _ = PasswordUnderling
getLetterKind _ = PinLetter
getLetterEnvelope l = maybe 'q' (Char.toLower . fst) $ Text.uncons (qualShort l)
getLetterEnvelope _ = 'f' -- maybe 'q' (Char.toLower . fst) $ Text.uncons (qualShort l)
getTemplate _ = decodeUtf8 $(Data.FileEmbed.embedFile "templates/letter/fraport_renewal.md")
letterMeta l@LetterRenewQualificationF{..} DateTimeFormatter{ format } lang Entity{entityKey=rcvrId, entityVal=User{userDisplayName}} =

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

10
stack.yaml
View File

@ -7,8 +7,12 @@ flags:
cffi: true
rebuild-ghc-options: true
ghc-options:
"$everything": -fno-prof-auto
#ghc-options:
# "$everything": -fno-prof-auto
build:
library-profiling: true
executable-profiling: true
nix:
packages: []
@ -67,7 +71,7 @@ extra-deps:
commit: 843683d024f767de236f74d24a3348f69181a720
- git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb
commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 # <- references debug with traceStack; master ref: cb75191e0c5490246ae2cbcc2a00e7985cf2aadb
subdirs:
- yesod-core
- yesod-static

58
stack.yaml.lock
View File

@ -240,12 +240,12 @@ packages:
git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
pantry-tree:
size: 5954
sha256: bca827b8f5b4b649ef6d8f0e06fc5ae9b825f9def16fb472173d2fbf12fb5dc2
commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb
sha256: 08c8da10b32c8d9f784238fd87232bf90b752e82f81ef2c52c62210f9aadda9a
commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
original:
subdir: yesod-core
git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb
commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
- completed:
subdir: yesod-static
name: yesod-static
@ -254,11 +254,11 @@ packages:
pantry-tree:
size: 2949
sha256: 32c1608243a5309005ce11e2aa379ac1d6f8c380c529785eb510770118f3da06
commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb
commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
original:
subdir: yesod-static
git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb
commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
- completed:
subdir: yesod-persistent
name: yesod-persistent
@ -267,11 +267,11 @@ packages:
pantry-tree:
size: 497
sha256: 3778ef2964e1a3890afc22cc9124eacb40e64b62bed4983a85d3b99897f54c5c
commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb
commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
original:
subdir: yesod-persistent
git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb
commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
- completed:
subdir: yesod-newsfeed
name: yesod-newsfeed
@ -280,11 +280,11 @@ packages:
pantry-tree:
size: 488
sha256: 53ebad62655863a657dcf749ffd3de46f6af90dd71f55bc4d50805ac48ddb099
commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb
commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
original:
subdir: yesod-newsfeed
git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb
commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
- completed:
subdir: yesod-form
name: yesod-form
@ -293,11 +293,11 @@ packages:
pantry-tree:
size: 1914
sha256: 260b7f16a8e1d58da137eb91aeed3a11ccbe59ba3e614457a635b9dc3e71426f
commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb
commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
original:
subdir: yesod-form
git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb
commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
- completed:
subdir: yesod-form-multi
name: yesod-form-multi
@ -306,11 +306,11 @@ packages:
pantry-tree:
size: 328
sha256: b21fc50db43733dfe6e285345856610ba4feb83329e9cf953bf8047ba18ecbd6
commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb
commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
original:
subdir: yesod-form-multi
git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb
commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
- completed:
subdir: yesod-auth
name: yesod-auth
@ -319,11 +319,11 @@ packages:
pantry-tree:
size: 1212
sha256: d335b940a207f8155f421b7146746a72d20db6ad54412154f2c829a59bf21e08
commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb
commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
original:
subdir: yesod-auth
git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb
commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
- completed:
subdir: yesod-auth-oauth
name: yesod-auth-oauth
@ -332,11 +332,11 @@ packages:
pantry-tree:
size: 321
sha256: 39d2f7d5d1abb3a2953858c5f23880e60ecfcdad0549ddc2570204f9c47649f4
commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb
commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
original:
subdir: yesod-auth-oauth
git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb
commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
- completed:
subdir: yesod-sitemap
name: yesod-sitemap
@ -345,11 +345,11 @@ packages:
pantry-tree:
size: 314
sha256: 971f48af7011ff7816872d067e5de9cadafdd371bdf209170b77df36001abd27
commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb
commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
original:
subdir: yesod-sitemap
git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb
commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
- completed:
subdir: yesod-test
name: yesod-test
@ -358,11 +358,11 @@ packages:
pantry-tree:
size: 563
sha256: 3d5022e8e3f8e77abcf075c42cf49efaa26f4951159bbb5ab50b69fdfeacb7c1
commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb
commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
original:
subdir: yesod-test
git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb
commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
- completed:
subdir: yesod-bin
name: yesod-bin
@ -371,11 +371,11 @@ packages:
pantry-tree:
size: 1295
sha256: 422d7816965b79826c6c24582d76dadbacd1bfb3e9a8f31208867cd788f2a5b8
commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb
commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
original:
subdir: yesod-bin
git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb
commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
- completed:
subdir: yesod
name: yesod
@ -384,11 +384,11 @@ packages:
pantry-tree:
size: 666
sha256: cb53ef3f2036185d2b4752d6fbc5d78470b4504e646e7eb4dd2397f2599daf42
commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb
commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
original:
subdir: yesod
git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb
commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
- completed:
subdir: yesod-eventsource
name: yesod-eventsource
@ -397,11 +397,11 @@ packages:
pantry-tree:
size: 324
sha256: 6d393201852cd024e377159ba836398e24d191563e08165430113d3c1384aff2
commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb
commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
original:
subdir: yesod-eventsource
git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb
commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
- completed:
subdir: yesod-websockets
name: yesod-websockets
@ -410,11 +410,11 @@ packages:
pantry-tree:
size: 485
sha256: 02df6117e9b74a77879ea750130ba2d8ad8d3c99e14ca678320cb578984301e5
commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb
commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
original:
subdir: yesod-websockets
git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb
commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
- completed:
name: cryptonite
version: '0.29'

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

130
templates/letter/fraport_f_expiry.md Normal file
View File

@ -0,0 +1,130 @@
---
### Metadaten, welche hier eingestellt werden:
# Absender
de-subject: 'Entzug "F" (Vorfeldführerschein)'
en-subject: Revocation of apron driving license
author: Fraport AG - Fahrerausbildung (AVN-AR)
phone: +49 69 690-28467
email: fahrerausbildung@fraport.de
place: Frankfurt am Main
return-address:
- 60547 Frankfurt
de-opening: Liebe Fahrberechtigungsinhaber,
en-opening: Dear driver,
de-closing: |
Mit freundlichen Grüßen,
Ihre Fraport Fahrerausbildung
en-closing: |
With kind regards,
Your Fraport Driver Training
encludes:
hyperrefoptions: hidelinks
### Metadaten, welche automatisch ersetzt werden:
date: 11.11.1111
expiry: 00.00.0000
lang: de-de
is-de: true
# Emfpänger
licenceholder: P. Rüfling
address:
- E. M. Pfänger
- Musterfirma GmbH
- Musterstraße 11
- 12345 Musterstadt
...
$if(titleblock)$
$titleblock$
$endif$
$for(header-includes)$
$header-includes$
$endfor$
$for(include-before)$
$include-before$
$endfor$
$if(is-de)$
<!-- deutsche Version des Briefes -->
$if(supervisor)$
leider hat $licenceholder$
$else$
leider haben Sie
$endif$
den Wissenstest im Rahmen des Recurrent Trainings Vorfeldführerschein nicht bestanden
oder die Ablauffrist nicht eingehalten.
Die Qualifikation „Vorfeldführerschein“ ist somit nicht mehr gültig.
$if(supervisor)$
**$licenceholder$** darf
$else$
Sie dürfen
$endif$
ab sofort keine Fahrzeuge mehr eigenständig auf dem Vorfeld des Frankfurter Flughafens führen.
Um die Fahrberechtigung wiederzuerlangen, ist die Teilnahme an einem Grundkurs Vorfeldführerschein erforderlich.
$if(supervisor)$
Hierfür wenden Sie sich bitte an die Fahrerausbildung der Fraport AG unter:
Telefon
: $phone$
Email
: $email$
$else$
Hierfür wenden Sie sich bitte an Ihren Arbeitgeber.
$endif$
$else$
<!-- englische Version des Briefes -->
we regret to inform you that
$if(supervisor)$
**$licenceholder$**
$else$
you
$endif$
did not pass the required knowledge test within the alotted time
for the renewal of the apron driving licence.
The qualification „Vorfeldführerschein“ (apron driving lincence) is therefore invalid now.
$if(supervisor)$
$licenceholder$
$else$
You
$endif$
may no longer drive a vehicle on the apron of Frankfurt airport, effective immediately.
In order to regain this apron driving licence, a full participation in a
basic training course is required.
$if(supervisor)$
Please contact the Fraport driving school team, if you want to book a course:
Phone
: $phone$
Email
: $email$
$else$
Please contact you employer to book a course for you.
$endif$
$endif$

82
templates/letter/fraport_qualification.md
View File

@ -5,18 +5,19 @@
lang: de-de
is-de: true
date: 11.11.1111
test1: this **is really** a test
test2: 'this **is another** test'
test3: |
<h1>First</h1>
<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 +28,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 +75,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 +98,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

4
templates/letter/fraport_renewal.md
View File

@ -13,7 +13,7 @@ de-opening: Liebe Fahrberechtigungsinhaber,
en-opening: Dear driver,
de-closing: |
Mit freundlichen Grüßen,
Ihre Fahrerausbildung
Ihre Fraport Fahrerausbildung
en-closing: |
With kind regards,
Your Fraport Driver Training
@ -133,7 +133,7 @@ $if(supervisor)$
to regain the apron driving licence.
$else$
you have to participate in a basic training course again to regain
your apron driving licnece.
your apron driving licence.
$endif$

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
insert_ $ UserAvsCard (AvsPersonId 12345678) (AvsFullCardNo (AvsCardNo "1234") "4") (AvsDataPersonCard True Nothing Nothing AvsCardColorGelb (Set.fromList ['F']) Nothing Nothing Nothing Nothing (AvsCardNo "1234") "4") now
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
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
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.