Merge branch 'fradrive/letter'
This commit is contained in:
commit
d4ea9e8088
1
db.sh
1
db.sh
@ -13,4 +13,5 @@ fi
|
||||
stack build --fast --flag uniworx:-library-only --flag uniworx:dev
|
||||
|
||||
export SERVER_SESSION_ACID_FALLBACK=${SERVER_SESSION_ACID_FALLBACK:-true}
|
||||
export AVSPASS=${AVSPASS:-nopasswordset}
|
||||
stack exec uniworxdb -- $@
|
||||
|
||||
@ -22,6 +22,7 @@ UnauthorizedExamOffice: Sie sind nicht mit Prüfungsverwaltung beauftragt.
|
||||
UnauthorizedExamExamOffice: Es existieren keine Prüfungsergebnisse für Nutzer:innen, für die Sie mit der Prüfungsverwaltung beauftragt sind.
|
||||
UnauthorizedSchoolExamOffice: Sie sind nicht mit Prüfungsverwaltung für dieses Institut beauftragt.
|
||||
UnauthorizedSystemExamOffice: Sie sind nicht mit systemweiter Prüfungsverwaltung beauftragt.
|
||||
UnauthorizedSystemPrinter: Sie sind nicht mit systemweitem Druck und Briefversand beauftragt.
|
||||
UnauthorizedExternalExamExamOffice: Es existieren keine Prüfungsergebnisse für Nutzer:innen, für die Sie mit der Prüfungsverwaltung beauftragt sind.
|
||||
UnauthorizedEvaluation: Sie sind nicht mit der Kursumfragenverwaltung beauftragt.
|
||||
UnauthorizedAllocationAdmin: Sie sind nicht mit der Administration von Zentralanmeldungen beauftragt.
|
||||
|
||||
@ -23,7 +23,8 @@ UnauthorizedEvaluation: You are not charged with course evaluation.
|
||||
UnauthorizedAllocationAdmin: You are not charged with the administration of central allocations.
|
||||
UnauthorizedExamExamOffice: You are not part of the appropriate exam office for any of the participants of this exam.
|
||||
UnauthorizedSchoolExamOffice: You are not part of an exam office for this school.
|
||||
UnauthorizedSystemExamOffice: You are not charged with system wide exam administration
|
||||
UnauthorizedSystemExamOffice: You are not charged with system wide exam administration.
|
||||
UnauthorizedSystemPrinter: You are not charged with system wide letter printing.
|
||||
UnauthorizedExternalExamExamOffice: You are not part of the appropriate exam office for any of the participants of this exam.
|
||||
UnauthorizedSchoolLecturer: You are no lecturer for this department.
|
||||
UnauthorizedLecturer: You are no administrator for this course.
|
||||
|
||||
@ -14,3 +14,4 @@ BothSubmissions: Abgabe direkt in Uni2work oder extern mit Pseudonym
|
||||
SystemExamOffice: Prüfungsverwaltung
|
||||
SystemFaculty: Fakultätsmitglied
|
||||
SystemStudent: Student:in
|
||||
SystemPrinter: Drucker:in
|
||||
|
||||
@ -14,3 +14,4 @@ BothSubmissions: Submission either directly in Uni2work or externally via pseudo
|
||||
SystemExamOffice: Exam office
|
||||
SystemFaculty: Faculty member
|
||||
SystemStudent: Student
|
||||
SystemPrinter: Printing staff
|
||||
@ -9,10 +9,10 @@ QualificationElearningStart: E-Lernen automatisch starten
|
||||
TableQualificationCountActive: Aktive
|
||||
TableQualificationCountActiveTooltip: Anzahl Personen mit momentan gültiger Qualifikation
|
||||
TableQualificationCountTotal: Gesamt
|
||||
TableQualificationValidUntil: Gültig bis
|
||||
LmsQualificationValidUntil: Gültig bis
|
||||
TableQualificationLastRefresh: Zuletzt erneuert
|
||||
TableQualificationFirstHeld: Erstmalig
|
||||
TableLmsUser: Ermächtigter
|
||||
LmsUser: Inhaber
|
||||
TableLmsEmail: E-Mail
|
||||
TableLmsIdent: Identifikation
|
||||
TableLmsElearning: E-Lernen
|
||||
@ -44,9 +44,12 @@ LmsResultCsvExceptionDuplicatedKey: CSV Import fand uneindeutigen Schlüssel
|
||||
LmsUserlistCsvExceptionDuplicatedKey: CSV Import fand uneindeutigen Schlüssel
|
||||
LmsDirectUpload: Direkter Upload für automatisierte Systeme
|
||||
LmsErrorNoRefreshElearning: Fehler: E-Lernen wird nicht automatisch gestartet, da die Zeitspanne für den Erneurerungszeitraum nicht festgelegt wurde.
|
||||
MailSubjectQualificationRenewal qname@Text: Ihre Qualifikation #{qname} muss demnächst erneuert werden
|
||||
MailSubjectQualificationExpiry qname@Text: Ihre Qualifikation #{qname} läuft demnächst ab
|
||||
MailLmsRenewalBody: Sie müssen diese Qualifikaton demnächst durch einen E-Lernen Kurs erneuern.
|
||||
MailSubjectQualificationRenewal qname@Text: Qualifikation #{qname} muss demnächst erneuert werden
|
||||
MailSubjectQualificationExpiry qname@Text: Qualifikation #{qname} läuft demnächst ab
|
||||
MailBodyQualificationRenewal: Sie müssen diese Qualifikaton demnächst durch einen E-Lernen Kurs erneuern.
|
||||
MailBodyQualificationExpiry: Diese Qualifikaton läuft bald ab. Tätigkeiten, welche diese Qualifikation voraussetzen dürfen dann nicht länger ausgeübt werden!
|
||||
LmsRenewalInstructions: Anweisungen zur Verlängerung finden Sie im angehängten PDF. Um Missbrauch zu verhindern wurde das PDF dem von Ihnen in FRADrive hinterlegten PIN-Passwort verschlüsselt. Falls kein PIN-Passwort hinterlegt wurde, ist das Passwort ihre Fraport Ausweisnummer, inklusive Punkt und der Ziffer danach.
|
||||
LmsNoRenewal: Leider kann diese Qualifikation nicht alleine durch E-Lernen verlängert werden.
|
||||
LmsActNotify: Benachrichtigung E-Lernen erneut per Post oder E-Mail versenden
|
||||
LmsActRenewPin: Neue zufällige E-Lernen PIN zuweisen
|
||||
LmsActRenewNotify: Neue zufällige E-Lernen PIN zuweisen und Benachrichtigung per Post oder E-Mail versenden
|
||||
|
||||
@ -9,10 +9,10 @@ QualificationElearningStart: Start e-learning automatically
|
||||
TableQualificationCountActive: Active
|
||||
TableQualificationCountActiveTooltip: Number of currently valid qualification holders
|
||||
TableQualificationCountTotal: Total
|
||||
TableQualificationValidUntil: Valid until
|
||||
LmsQualificationValidUntil: Valid until
|
||||
TableQualificationLastRefresh: Last renewed
|
||||
TableQualificationFirstHeld: First held
|
||||
TableLmsUser: Licensee
|
||||
LmsUser: Licensee
|
||||
TableLmsEmail: Email
|
||||
TableLmsIdent: Identifier
|
||||
TableLmsPin: E-learning pin
|
||||
@ -29,7 +29,7 @@ TableLmsSuccess: Completed
|
||||
TableLmsFailed: Blocked
|
||||
FilterLmsValid: Currently valid
|
||||
FilterLmsRenewal: Renewal due
|
||||
CsvColumnLmsIdent: E-learning identifier, unique for each qualfication and user
|
||||
CsvColumnLmsIdent: E-learning identifier, unique for each qualification and user
|
||||
CsvColumnLmsPin: PIN for e-learning access
|
||||
CsvColumnLmsResetPin: Will the e-learning PIN be reset upon next synchronisation?
|
||||
CsvColumnLmsDelete: Will the identifier be deleted from the E-learning platfrom upon next synchronisation?
|
||||
@ -44,9 +44,12 @@ LmsResultCsvExceptionDuplicatedKey: CSV import with ambiguous key
|
||||
LmsUserlistCsvExceptionDuplicatedKey: CSV import with ambiguous key
|
||||
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@Text: Your qualification #{qname} must be renewed shortly
|
||||
MailSubjectQualificationExpiry qname@Text: Your qualification #{qname} expires soon
|
||||
MailLmsRenewalBody: You will soon need to renew this qualficiation by completing an e-learning course.
|
||||
MailSubjectQualificationRenewal qname@Text: Qualification #{qname} must be renewed shortly
|
||||
MailSubjectQualificationExpiry qname@Text: Qualification #{qname} expires soon
|
||||
MailBodyQualificationRenewal: You will soon need to renew this qualficiation by completing an e-learning course.
|
||||
MailBodyQualificationExpiry: This qualificaton expires soon. You may then no longer execute any duties that require this qualification as a precondition!
|
||||
LmsRenewalInstructions: Instruction on how to accomplish the renewal are enclosed in the attached PDF. In order to avoid misuse, the PDF is encrypted with your chosen FRADrive PIN-Password. If you have not yet chosen a PIN-Password yet, then the password is your Fraport id card number, inkluding the punctuation mark and the Digit thereafter.
|
||||
LmsNoRenewal: Unfortunately, this particular qualification cannot be renewed through E-learning only.
|
||||
LmsActNotify: Resend e-learning notification by post or email
|
||||
LmsActRenewPin: Randomly replace e-learning PIN
|
||||
LmsActRenewNotify: Randomly replace e-learning PIN and re-send notification by post or email
|
||||
|
||||
@ -9,6 +9,7 @@ AuthTagFree: Seite ist universell zugänglich
|
||||
AuthTagAdmin: Nutzer:in ist Administrator:in
|
||||
AuthTagExamOffice: Nutzer:in ist mit Prüfungsverwaltung beauftragt
|
||||
AuthTagSystemExamOffice: Nutzer:in ist mit systemweiter Prüfungsverwaltung beauftragt
|
||||
AuthTagSystemPrinter: Nutzer:in ist mit systemweiten Druck von Briefen beauftragt
|
||||
AuthTagEvaluation: Nutzer:in ist mit Kursumfragenverwaltung beauftragt
|
||||
AuthTagAllocationAdmin: Nutzer:in ist mit der Administration von Zentralanmeldungen beauftragt
|
||||
AuthTagToken: Nutzer:in präsentiert Authorisierungs-Token
|
||||
|
||||
@ -9,6 +9,7 @@ AuthTagFree: Page is freely accessable
|
||||
AuthTagAdmin: User is administrator
|
||||
AuthTagExamOffice: User is part of an exam office
|
||||
AuthTagSystemExamOffice: User is charged with system wide exam administration
|
||||
AuthTagSystemPrinter: User is responsible for system wide letter printing
|
||||
AuthTagEvaluation: User is charged with course evaluation
|
||||
AuthTagAllocationAdmin: User is charged with administration of central allocations
|
||||
AuthTagToken: User is presenting an authorisation-token
|
||||
|
||||
@ -12,6 +12,9 @@ AdminUserTelephone: Telefonnummer
|
||||
AdminUserMobile: Mobiltelefonmummer
|
||||
AdminUserFPersonalNumber: Personalnummer (nur Fraport AG)
|
||||
AdminUserFDepartment: Abteilung
|
||||
AdminUserPostAddress: Postalische Anschrift
|
||||
AdminUserPrefersPostal: Briefe anstatt Email bevorzugt
|
||||
AdminUserPinPassword: Passwort zur Verschlüsselung von PDF Anhängen in Emails
|
||||
AdminUserAssimilate: Benutzer assimilieren
|
||||
UserAdded: Benutzer erfolgreich angelegt
|
||||
UserCollision: Benutzer konnte wegen Eindeutigkeit nicht angelegt werden
|
||||
|
||||
@ -12,6 +12,9 @@ AdminUserTelephone: Phone
|
||||
AdminUserMobile: Mobile
|
||||
AdminUserFPersonalNumber: Personalnumber (Fraport AG only)
|
||||
AdminUserFDepartment: Department
|
||||
AdminUserPostAddress: Postal Address
|
||||
AdminUserPrefersPostal: Prefers postal letters over email
|
||||
AdminUserPinPassword: Password used for all PDF attachments to emails
|
||||
AdminUserAssimilate: Assimilate user
|
||||
UserAdded: Successfully added user
|
||||
UserCollision: Could not create user due to uniqueness constraint
|
||||
|
||||
@ -130,7 +130,8 @@ MenuLmsUsers: Export E-Lernen Benutzer
|
||||
MenuLmsUserlist: Melden E-Lernen Benutzer
|
||||
MenuLmsResult: Melden Ergebnisse E-Lernen
|
||||
MenuLmsUpload: Hochladen
|
||||
MenuLmsDirect: Direkter Upload
|
||||
MenuLmsDirect: Direkter Upload
|
||||
MenuLmsFake: Testnutzer generieren
|
||||
|
||||
MenuAvs: Schnittstelle AVS
|
||||
MenuApc: Druckerei
|
||||
|
||||
@ -132,6 +132,7 @@ MenuLmsUserlist: Upload E-Learning Users
|
||||
MenuLmsResult: Upload E-Learning Results
|
||||
MenuLmsUpload: Upload
|
||||
MenuLmsDirect: Direct Upload
|
||||
MenuLmsFake: Generate test users
|
||||
|
||||
MenuAvs: AVS Interface
|
||||
MenuApc: Printing
|
||||
|
||||
@ -1,12 +1,12 @@
|
||||
Qualification
|
||||
-- INVARIANT: 2*refreshWithin < validDuration
|
||||
school SchoolId --TODO: Ansprechpartner der Schule in Briefe erwähnen
|
||||
school SchoolId --TODO: Ansprechpartner der Schule in Briefe erwähnen
|
||||
shorthand (CI Text)
|
||||
name (CI Text)
|
||||
description StoredMarkup Maybe -- user-defined large Html, ought to contain full description
|
||||
validDuration Word Maybe -- qualification is valid indefinitely or for a specified number of months
|
||||
validDuration Word Maybe -- qualification is valid indefinitely or for a specified number of months
|
||||
auditDuration Word Maybe -- number of month to keep audit log; or indefinitely
|
||||
refreshWithin CalendarDiffDays Maybe -- notify users about renewal within this number of month/days before expiry
|
||||
refreshWithin CalendarDiffDays Maybe -- notify users about renewal within this number of month/days before expiry; to be used with addGregorianDurationClip
|
||||
elearningStart Bool -- automatically schedule e-refresher
|
||||
-- elearningOnly Bool -- successful E-learing automatically increases validity. NO!
|
||||
-- refreshInvitation StoredMarkup -- hard-coded I18N-MSGs used instead, but displayed on qualification page NO!
|
||||
|
||||
@ -11,7 +11,7 @@ User json -- Each Uni2work user has a corresponding row in this table; create
|
||||
surname UserSurname -- Display user names always through 'nameWidget displayName surname'
|
||||
displayName UserDisplayName
|
||||
displayEmail UserEmail
|
||||
email UserEmail -- Case-insensitive eMail address
|
||||
email UserEmail -- Case-insensitive eMail address -- TODO: make this nullable
|
||||
ident UserIdent -- Case-insensitive user-identifier
|
||||
authentication AuthenticationMode -- 'AuthLDAP' or ('AuthPWHash'+password-hash)
|
||||
lastAuthentication UTCTime Maybe -- last login date
|
||||
@ -39,8 +39,11 @@ User json -- Each Uni2work user has a corresponding row in this table; create
|
||||
mobile Text Maybe
|
||||
companyPersonalNumber Text Maybe -- Company will become a new table, but if company=fraport, some information is received via LDAP
|
||||
companyDepartment Text Maybe -- thus we store such information for ease of reference directly, if available
|
||||
examOfficeGetSynced Bool default=true -- whether synced status should be displayed for exam results by default
|
||||
examOfficeGetLabels Bool default=true -- whether labels should be displayed for exam results by default
|
||||
pinPassword Text Maybe -- used to encrypt pins within emails
|
||||
postAddress StoredMarkup Maybe
|
||||
prefersPostal Bool default=false -- user prefers letters by post instead of email
|
||||
examOfficeGetSynced Bool default=true -- whether synced status should be displayed for exam results by default
|
||||
examOfficeGetLabels Bool default=true -- whether labels should be displayed for exam results by default
|
||||
UniqueAuthentication ident -- Column 'ident' can be used as a row-key in this table
|
||||
UniqueEmail email -- Column 'email' can be used as a row-key in this table
|
||||
deriving Show Eq Ord Generic -- Haskell-specific settings for runtime-value representing a row in memory
|
||||
@ -53,9 +56,9 @@ UserFunction -- Administratively assigned functions (lecturer, admin, evaluation
|
||||
deriving Generic
|
||||
UserSystemFunction
|
||||
user UserId
|
||||
function SystemFunction
|
||||
manual Bool
|
||||
isOptOut Bool
|
||||
function SystemFunction -- Defined in Model.Types.User
|
||||
manual Bool -- Inserted manually by Admin or automatic from LDAP
|
||||
isOptOut Bool -- User has currently deactivate the role for themselves
|
||||
UniqueUserSystemFunction user function
|
||||
deriving Generic
|
||||
UserExamOffice
|
||||
|
||||
9
routes
9
routes
@ -9,6 +9,8 @@
|
||||
--
|
||||
-- Admins always have access to entities within their assigned schools.
|
||||
--
|
||||
-- Access tags are defined in Model.Types.Security
|
||||
--
|
||||
-- Access Tags:
|
||||
-- !free -- free for all
|
||||
-- !lecturer -- lecturer for this course (or for any school, if route is not connected to a course)
|
||||
@ -61,9 +63,9 @@
|
||||
/admin/crontab AdminCrontabR GET
|
||||
/admin/avs AdminAvsR GET POST
|
||||
|
||||
/print PrintCenterR GET POST
|
||||
/print PrintCenterR GET POST !system-printer
|
||||
/print/send PrintSendR GET POST
|
||||
/print/download/#CryptoUUIDPrintJob PrintDownloadR GET
|
||||
/print/download/#CryptoUUIDPrintJob PrintDownloadR GET !system-printer
|
||||
|
||||
/health HealthR GET !free
|
||||
/instance InstanceR GET !free
|
||||
@ -263,7 +265,7 @@
|
||||
-- for users
|
||||
/qualification QualificationAllR GET !free
|
||||
/qualification/#SchoolId QualificationSchoolR GET !free -- TODO
|
||||
/qualification/#SchoolId/#QualificationShorthand QualificationR GET !free -- must be logged in though
|
||||
/qualification/#SchoolId/#QualificationShorthand QualificationR GET -- TODO make !free again after repurpose
|
||||
-- OSIS CSV Export Demo
|
||||
/lms LmsAllR GET POST
|
||||
/lms/#SchoolId LmsSchoolR GET
|
||||
@ -277,6 +279,7 @@
|
||||
/lms/#SchoolId/#QualificationShorthand/result LmsResultR GET POST
|
||||
/lms/#SchoolId/#QualificationShorthand/result/upload LmsResultUploadR GET POST
|
||||
/lms/#SchoolId/#QualificationShorthand/result/direct LmsResultDirectR POST
|
||||
/lms/#SchoolId/#QualificationShorthand/fake LmsFakeR GET POST -- TODO: delete this testing URL
|
||||
|
||||
/api ApiDocsR GET !free
|
||||
/swagger SwaggerR GET !free
|
||||
|
||||
@ -347,11 +347,11 @@ makeFoundation appSettings''@AppSettings{..} = do
|
||||
|
||||
appAvsQuery <- case appAvsConf of
|
||||
Nothing -> do
|
||||
$logErrorS "avsPrepare" "appAvsConfig is empty, i.e. invalid AVS configuration settings."
|
||||
return Nothing
|
||||
-- liftIO exitFailure
|
||||
Just avsConf -> do
|
||||
-- TODO: consider using Servant.Client.Core.BaseUrl.Instances.parseBaseUrl' within Settings already at Startup!
|
||||
-- $logErrorS "avsPrepare" "appAvsConfig is empty, i.e. invalid AVS configuration settings."
|
||||
-- return Nothing
|
||||
error "AvsConfig is empty, i.e. invalid AVS configuration settings."
|
||||
|
||||
Just avsConf -> do
|
||||
manager <- newManagerSettings $ mkManagerSettings (def { settingDisableCertificateValidation = True }) Nothing
|
||||
let avsServer = BaseUrl
|
||||
{ baseUrlScheme = Https
|
||||
@ -607,7 +607,7 @@ appMain = runResourceT $ do
|
||||
foundation <- makeFoundation settings
|
||||
|
||||
runAppLoggingT foundation $ do
|
||||
$logDebugS "setup" "Job-Handling"
|
||||
$logInfoS "setup" "Job-Handling"
|
||||
handleJobs foundation
|
||||
|
||||
-- Generate a WAI Application from the foundation
|
||||
|
||||
@ -1,3 +1,5 @@
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module Auth.LDAP
|
||||
( apLdap
|
||||
, ADError(..), ADInvalidCredentials(..)
|
||||
@ -13,6 +15,7 @@ module Auth.LDAP
|
||||
, ldapAffiliation
|
||||
, ldapUserMobile, ldapUserTelephone
|
||||
, ldapUserFraportPersonalnummer, ldapUserFraportAbteilung
|
||||
, ldapUserTitle
|
||||
) where
|
||||
|
||||
import Import.NoFoundation
|
||||
@ -30,6 +33,9 @@ import qualified Yesod.Auth.Message as Msg
|
||||
|
||||
import Auth.LDAP.AD
|
||||
|
||||
-- allow Ldap.Attr usage as key for Data.Map
|
||||
deriving newtype instance Ord Ldap.Attr
|
||||
|
||||
|
||||
data CampusLogin = CampusLogin
|
||||
{ campusIdent :: CI Text
|
||||
@ -72,29 +78,20 @@ userSearchSettings LdapConf{..} = mconcat
|
||||
, Ldap.derefAliases Ldap.DerefAlways
|
||||
]
|
||||
|
||||
ldapPrimaryKey, ldapUserPrincipalName, ldapUserDisplayName, ldapUserFirstName, ldapUserSurname, ldapAffiliation, ldapUserMobile, ldapUserTelephone, ldapUserFraportPersonalnummer, ldapUserFraportAbteilung :: Ldap.Attr
|
||||
ldapPrimaryKey, ldapUserPrincipalName, ldapUserDisplayName, ldapUserFirstName, ldapUserSurname, ldapAffiliation, ldapUserTitle, ldapUserTelephone, ldapUserMobile, ldapUserFraportPersonalnummer, ldapUserFraportAbteilung :: Ldap.Attr
|
||||
ldapPrimaryKey = Ldap.Attr "cn" -- should always be identical to "sAMAccountName"
|
||||
ldapUserPrincipalName = Ldap.Attr "userPrincipalName"
|
||||
ldapUserDisplayName = Ldap.Attr "displayName"
|
||||
ldapUserFirstName = Ldap.Attr "givenName"
|
||||
ldapUserSurname = Ldap.Attr "sn"
|
||||
ldapAffiliation = Ldap.Attr "memberOf" -- group determine user functions, see Handler.Utils.LdapSystemFunctions.determineSystemFunctions
|
||||
ldapUserTitle = Ldap.Attr "title" -- not used at Fraport
|
||||
-- new
|
||||
ldapUserTelephone = Ldap.Attr "telephoneNumber"
|
||||
ldapUserMobile = Ldap.Attr "mobile"
|
||||
ldapUserFraportPersonalnummer = Ldap.Attr "sAMAccountName"
|
||||
ldapUserFraportAbteilung = Ldap.Attr "department"
|
||||
|
||||
{- --outdated to be removed
|
||||
ldapUserMatriculation = Ldap.Attr "LMU-Stud-Matrikelnummer"
|
||||
ldapUserTitle = Ldap.Attr "title"
|
||||
ldapUserStudyFeatures = Ldap.Attr "dfnEduPersonFeaturesOfStudy"
|
||||
ldapUserFieldName = Ldap.Attr "LMU-Stg-Fach"
|
||||
ldapUserSchoolAssociation = Ldap.Attr "LMU-IFI-eduPersonOrgUnitDNString"
|
||||
ldapSex = Ldap.Attr "schacGender"
|
||||
ldapUserSubTermsSemester = Ldap.Attr "LMU-Stg-FachundFS"
|
||||
-}
|
||||
|
||||
ldapUserEmail :: NonEmpty Ldap.Attr
|
||||
ldapUserEmail = Ldap.Attr "mail" :|
|
||||
[ Ldap.Attr "userPrincipalName"
|
||||
|
||||
@ -555,6 +555,15 @@ tagAccessPredicate AuthSystemExamOffice = cacheAPSystemFunction SystemExamOffice
|
||||
isExamOffice <- lift $ exists [UserSystemFunctionUser ==. authId, UserSystemFunctionFunction ==. SystemExamOffice, UserSystemFunctionIsOptOut ==. False]
|
||||
guardMExceptT isExamOffice $ unauthorizedI MsgUnauthorizedSystemExamOffice
|
||||
return Authorized
|
||||
tagAccessPredicate AuthSystemPrinter = cacheAPSystemFunction SystemPrinter (Just $ Right diffHour) $ \mAuthId' _ _ printerList -> if
|
||||
| maybe True (`Set.notMember` printerList) mAuthId' -> Right $ if
|
||||
| is _Nothing mAuthId' -> return AuthenticationRequired
|
||||
| otherwise -> unauthorizedI MsgUnauthorizedSystemPrinter
|
||||
| otherwise -> Left $ APDB $ \_ _ mAuthId _ _ -> $cachedHereBinary mAuthId . exceptT return return $ do
|
||||
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
||||
isPrinter <- lift $ exists [UserSystemFunctionUser ==. authId, UserSystemFunctionFunction ==. SystemPrinter, UserSystemFunctionIsOptOut ==. False]
|
||||
guardMExceptT isPrinter $ unauthorizedI MsgUnauthorizedSystemPrinter
|
||||
return Authorized
|
||||
tagAccessPredicate AuthStudent = cacheAPSystemFunction SystemStudent (Just $ Right diffHour) $ \mAuthId' _ _ studentList -> if
|
||||
| maybe True (`Set.notMember` studentList) mAuthId' -> Right $ if
|
||||
| is _Nothing mAuthId' -> return AuthenticationRequired
|
||||
|
||||
@ -162,7 +162,7 @@ breadcrumb (LmsUserlistDirectR ssh qsh) = i18nCrumb MsgMenuLmsUpload $ Jus
|
||||
breadcrumb (LmsResultR ssh qsh) = i18nCrumb MsgMenuLmsResult $ Just $ LmsR ssh qsh
|
||||
breadcrumb (LmsResultUploadR ssh qsh) = i18nCrumb MsgMenuLmsUpload $ Just $ LmsResultR ssh qsh
|
||||
breadcrumb (LmsResultDirectR ssh qsh) = i18nCrumb MsgMenuLmsUpload $ Just $ LmsResultR ssh qsh -- never displayed
|
||||
|
||||
breadcrumb (LmsFakeR ssh qsh) = i18nCrumb MsgMenuLmsFake $ Just $ LmsR ssh qsh -- TODO: remove in production
|
||||
|
||||
breadcrumb ProfileR = i18nCrumb MsgBreadcrumbProfile Nothing
|
||||
breadcrumb SetDisplayEmailR = i18nCrumb MsgUserDisplayEmail $ Just ProfileR
|
||||
@ -2484,6 +2484,9 @@ pageActions (LmsR sid qsh) = return
|
||||
, NavPageActionSecondary {
|
||||
navLink = defNavLink MsgMenuLmsEdit $ LmsEditR sid qsh
|
||||
}
|
||||
, NavPageActionSecondary {
|
||||
navLink = defNavLink MsgMenuLmsFake $ LmsFakeR sid qsh
|
||||
}
|
||||
]
|
||||
pageActions ApiDocsR = return
|
||||
[ NavPageActionPrimary
|
||||
|
||||
@ -26,12 +26,13 @@ import qualified Control.Monad.Catch as C (Handler(..))
|
||||
import qualified Ldap.Client as Ldap
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.Text.Encoding as Text
|
||||
-- import qualified Data.ByteString as ByteString
|
||||
import qualified Data.ByteString as ByteString
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Map as Map
|
||||
-- import qualified Data.Conduit.Combinators as C
|
||||
|
||||
-- import qualified Data.List as List ((\\))
|
||||
|
||||
|
||||
-- import qualified Data.UUID as UUID
|
||||
-- import Data.ByteArray (convert)
|
||||
-- import Crypto.Hash (SHAKE128)
|
||||
@ -112,7 +113,7 @@ authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend
|
||||
_other
|
||||
-> acceptExisting
|
||||
|
||||
|
||||
|
||||
data CampusUserConversionException
|
||||
= CampusUserInvalidIdent
|
||||
| CampusUserInvalidEmail
|
||||
@ -120,7 +121,7 @@ data CampusUserConversionException
|
||||
| CampusUserInvalidGivenName
|
||||
| CampusUserInvalidSurname
|
||||
| CampusUserInvalidTitle
|
||||
| CampusUserInvalidMatriculation
|
||||
| CampusUserInvalidMatriculation
|
||||
| CampusUserInvalidFeaturesOfStudy Text
|
||||
| CampusUserInvalidAssociatedSchools Text
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
@ -155,22 +156,35 @@ upsertCampusUser upsertMode ldapData = do
|
||||
now <- liftIO getCurrentTime
|
||||
UserDefaultConf{..} <- getsYesod $ view _appUserDefaults
|
||||
|
||||
let
|
||||
userEmail' = fold $ do
|
||||
k' <- toList ldapUserEmail
|
||||
(k, v) <- ldapData
|
||||
guard $ k' == k
|
||||
return v
|
||||
-- SJ says: this highly repetitive code needs fefactoring; why not turn ldapData into a Data.Map right away instead of repetitive list iteration?
|
||||
userLdapPrimaryKey' = fold [ v | (k, v) <- ldapData, k == ldapPrimaryKey ]
|
||||
userIdent'' = fold [ v | (k, v) <- ldapData, k == ldapUserPrincipalName ]
|
||||
userDisplayName'' = fold [ v | (k, v) <- ldapData, k == ldapUserDisplayName ]
|
||||
userFirstName' = fold [ v | (k, v) <- ldapData, k == ldapUserFirstName ]
|
||||
userSurname' = fold [ v | (k, v) <- ldapData, k == ldapUserSurname ]
|
||||
userTelephone' = fold [ v | (k, v) <- ldapData, k == ldapUserTelephone ]
|
||||
userMobile' = fold [ v | (k, v) <- ldapData, k == ldapUserMobile ]
|
||||
userFraportPersonalnummer' = fold [ v | (k, v) <- ldapData, k == ldapUserFraportPersonalnummer ]
|
||||
userFraportAbteilung' = fold [ v | (k, v) <- ldapData, k == ldapUserFraportAbteilung ]
|
||||
let
|
||||
ldapMap :: Map.Map Ldap.Attr [Ldap.AttrValue] -- Recall: Ldap.AttrValue == ByteString
|
||||
ldapMap = Map.fromListWith (++) $ ldapData <&> second (filter (not . ByteString.null))
|
||||
|
||||
-- only accept a single result, throw error otherwise
|
||||
-- decodeLdap1 :: (MonadThrow m, Exception e) => Ldap.Attr -> e -> m Text
|
||||
decodeLdap1 attr err
|
||||
| [bs] <- ldapMap !!! attr
|
||||
, Right t <- Text.decodeUtf8' bs
|
||||
= return t
|
||||
| otherwise = throwM err
|
||||
|
||||
-- accept any successful decoding or empty; only throw an error if all decodings fail
|
||||
-- decodeLdap' :: (Exception e) => Ldap.Attr -> e -> m Text
|
||||
decodeLdap' attr err
|
||||
| [] <- vs = return Nothing
|
||||
| (h:_) <- rights vs = return $ Just h
|
||||
| otherwise = throwM err
|
||||
where
|
||||
vs = Text.decodeUtf8' <$> ldapMap !!! attr
|
||||
|
||||
-- just returns Nothing on error, pure
|
||||
decodeLdap :: Ldap.Attr -> Maybe Text
|
||||
decodeLdap attr = listToMaybe . rights $ Text.decodeUtf8' <$> ldapMap !!! attr
|
||||
|
||||
userTelephone = decodeLdap ldapUserTelephone
|
||||
userMobile = decodeLdap ldapUserMobile
|
||||
userCompanyPersonalNumber = decodeLdap ldapUserFraportPersonalnummer
|
||||
userCompanyDepartment = decodeLdap ldapUserFraportAbteilung
|
||||
|
||||
userAuthentication
|
||||
| is _UpsertCampusUserLoginOther upsertMode
|
||||
@ -180,7 +194,7 @@ upsertCampusUser upsertMode ldapData = do
|
||||
isLogin = has (_UpsertCampusUserLoginLdap <> _UpsertCampusUserLoginOther . united) upsertMode
|
||||
|
||||
userIdent <- if
|
||||
| [bs] <- userIdent''
|
||||
| [bs] <- ldapMap !!! ldapUserPrincipalName
|
||||
, Right userIdent' <- CI.mk <$> Text.decodeUtf8' bs
|
||||
, hasn't _upsertCampusUserIdent upsertMode || has (_upsertCampusUserIdent . only userIdent') upsertMode
|
||||
-> return userIdent'
|
||||
@ -188,56 +202,21 @@ upsertCampusUser upsertMode ldapData = do
|
||||
-> return userIdent'
|
||||
| otherwise
|
||||
-> throwM CampusUserInvalidIdent
|
||||
|
||||
userEmail <- if
|
||||
| userEmail : _ <- mapMaybe (assertM (elem '@') . either (const Nothing) Just . Text.decodeUtf8') userEmail'
|
||||
| userEmail : _ <- mapMaybe (assertM (elem '@') . either (const Nothing) Just . Text.decodeUtf8') (lookupSome ldapMap $ toList ldapUserEmail)
|
||||
-> return $ CI.mk userEmail
|
||||
| otherwise
|
||||
-> throwM CampusUserInvalidEmail
|
||||
userDisplayName' <- if
|
||||
| [bs] <- userDisplayName''
|
||||
, Right userDisplayName' <- Text.decodeUtf8' bs
|
||||
-> return userDisplayName'
|
||||
| otherwise
|
||||
-> throwM CampusUserInvalidDisplayName
|
||||
userFirstName <- if
|
||||
| [bs] <- userFirstName'
|
||||
, Right userFirstName <- Text.decodeUtf8' bs
|
||||
-> return userFirstName
|
||||
| otherwise
|
||||
-> throwM CampusUserInvalidGivenName
|
||||
userSurname <- if
|
||||
| [bs] <- userSurname'
|
||||
, Right userSurname <- Text.decodeUtf8' bs
|
||||
-> return userSurname
|
||||
| otherwise
|
||||
-> throwM CampusUserInvalidSurname
|
||||
userTelephone <- if
|
||||
| [bs] <- userTelephone'
|
||||
, Right userTelephone <- Text.decodeUtf8' bs
|
||||
-> return $ Just userTelephone
|
||||
| otherwise
|
||||
-> return Nothing
|
||||
userMobile <- if
|
||||
| [bs] <- userMobile'
|
||||
, Right userMobile <- Text.decodeUtf8' bs
|
||||
-> return $ Just userMobile
|
||||
| otherwise
|
||||
-> return Nothing
|
||||
userCompanyPersonalNumber <- if
|
||||
| [bs] <- userFraportPersonalnummer'
|
||||
, Right dt <- Text.decodeUtf8' bs
|
||||
-> return $ Just dt
|
||||
| otherwise
|
||||
-> return Nothing
|
||||
userCompanyDepartment <- if
|
||||
| [bs] <- userFraportAbteilung'
|
||||
, Right dt <- Text.decodeUtf8' bs
|
||||
-> return $ Just dt
|
||||
| otherwise
|
||||
-> return Nothing
|
||||
userFirstName <- decodeLdap1 ldapUserFirstName CampusUserInvalidGivenName
|
||||
userSurname <- decodeLdap1 ldapUserSurname CampusUserInvalidSurname
|
||||
userTitle <- decodeLdap' ldapUserTitle CampusUserInvalidTitle
|
||||
|
||||
userDisplayName' <- decodeLdap1 ldapUserDisplayName CampusUserInvalidDisplayName >>=
|
||||
(maybeThrow CampusUserInvalidDisplayName . checkDisplayName userTitle userFirstName userSurname)
|
||||
|
||||
userLdapPrimaryKey <- if
|
||||
| [bs] <- userLdapPrimaryKey'
|
||||
| [bs] <- ldapMap !!! ldapPrimaryKey
|
||||
, Right userLdapPrimaryKey'' <- Text.decodeUtf8' bs
|
||||
, Just userLdapPrimaryKey''' <- assertM' (not . Text.null) $ Text.strip userLdapPrimaryKey''
|
||||
-> return $ Just userLdapPrimaryKey'''
|
||||
@ -246,35 +225,37 @@ upsertCampusUser upsertMode ldapData = do
|
||||
|
||||
let
|
||||
newUser = User
|
||||
{ userMaxFavourites = userDefaultMaxFavourites
|
||||
, userMaxFavouriteTerms = userDefaultMaxFavouriteTerms
|
||||
, userTheme = userDefaultTheme
|
||||
, userDateTimeFormat = userDefaultDateTimeFormat
|
||||
, userDateFormat = userDefaultDateFormat
|
||||
, userTimeFormat = userDefaultTimeFormat
|
||||
, userDownloadFiles = userDefaultDownloadFiles
|
||||
, userWarningDays = userDefaultWarningDays
|
||||
, userShowSex = userDefaultShowSex
|
||||
, userSex = Nothing
|
||||
, userExamOfficeGetSynced = userDefaultExamOfficeGetSynced
|
||||
, userExamOfficeGetLabels = userDefaultExamOfficeGetLabels
|
||||
, userNotificationSettings = def
|
||||
, userLanguages = Nothing
|
||||
, userCsvOptions = def
|
||||
, userTokensIssuedAfter = Nothing
|
||||
, userCreated = now
|
||||
, userLastLdapSynchronisation = Just now
|
||||
, userDisplayName = userDisplayName'
|
||||
, userDisplayEmail = userEmail
|
||||
, userMatrikelnummer = Nothing -- not known from LDAP, must be derived from REST interface to AVS TODO
|
||||
, userTitle = Nothing
|
||||
{ userMaxFavourites = userDefaultMaxFavourites
|
||||
, userMaxFavouriteTerms = userDefaultMaxFavouriteTerms
|
||||
, userTheme = userDefaultTheme
|
||||
, userDateTimeFormat = userDefaultDateTimeFormat
|
||||
, userDateFormat = userDefaultDateFormat
|
||||
, userTimeFormat = userDefaultTimeFormat
|
||||
, userDownloadFiles = userDefaultDownloadFiles
|
||||
, userWarningDays = userDefaultWarningDays
|
||||
, userShowSex = userDefaultShowSex
|
||||
, userSex = Nothing
|
||||
, userExamOfficeGetSynced = userDefaultExamOfficeGetSynced
|
||||
, userExamOfficeGetLabels = userDefaultExamOfficeGetLabels
|
||||
, userNotificationSettings = def
|
||||
, userLanguages = Nothing
|
||||
, userCsvOptions = def
|
||||
, userTokensIssuedAfter = Nothing
|
||||
, userCreated = now
|
||||
, userLastLdapSynchronisation = Just now
|
||||
, userDisplayName = userDisplayName'
|
||||
, userDisplayEmail = userEmail
|
||||
, userMatrikelnummer = Nothing -- not known from LDAP, must be derived from REST interface to AVS TODO
|
||||
, userPostAddress = Nothing -- not known from LDAP, must be derived from REST interface to AVS TODO
|
||||
, userPinPassword = Nothing -- must be derived via AVS
|
||||
, userPrefersPostal = False
|
||||
, ..
|
||||
}
|
||||
userUpdate = [
|
||||
-- UserDisplayName =. userDisplayName -- never updated, since users are allowed to change their DisplayName
|
||||
userUpdate = [
|
||||
-- UserDisplayName =. userDisplayName -- not updated here, since users are allowed to change their DisplayName; see line 272
|
||||
UserFirstName =. userFirstName
|
||||
, UserSurname =. userSurname
|
||||
, UserEmail =. userEmail
|
||||
, UserSurname =. userSurname
|
||||
, UserEmail =. userEmail
|
||||
, UserLastLdapSynchronisation =. Just now
|
||||
, UserLdapPrimaryKey =. userLdapPrimaryKey
|
||||
, UserMobile =. userMobile
|
||||
@ -289,7 +270,7 @@ upsertCampusUser upsertMode ldapData = do
|
||||
user@(Entity userId userRec) <- case oldUsers of
|
||||
Just [oldUserId] -> updateGetEntity oldUserId userUpdate
|
||||
_other -> upsertBy (UniqueAuthentication userIdent) newUser userUpdate
|
||||
unless (validDisplayName Nothing userFirstName userSurname $ userDisplayName userRec) $
|
||||
unless (validDisplayName userTitle userFirstName userSurname $ userDisplayName userRec) $
|
||||
update userId [ UserDisplayName =. userDisplayName' ]
|
||||
|
||||
let
|
||||
@ -306,7 +287,7 @@ upsertCampusUser upsertMode ldapData = do
|
||||
if | preset -> void $ upsert (UserSystemFunction userId func False False) []
|
||||
| otherwise -> deleteWhere [UserSystemFunctionUser ==. userId, UserSystemFunctionFunction ==. func, UserSystemFunctionIsOptOut ==. False, UserSystemFunctionManual ==. False]
|
||||
|
||||
return user
|
||||
return user
|
||||
|
||||
associateUserSchoolsByTerms :: MonadIO m => UserId -> SqlPersistT m ()
|
||||
associateUserSchoolsByTerms uid = do
|
||||
@ -320,7 +301,7 @@ associateUserSchoolsByTerms uid = do
|
||||
, userSchoolSchool = schoolTermsSchool
|
||||
, userSchoolIsOptOut = False
|
||||
}
|
||||
|
||||
|
||||
updateUserLanguage :: ( MonadHandler m, HandlerSite m ~ UniWorX
|
||||
, YesodAuth UniWorX
|
||||
, UserId ~ AuthId UniWorX
|
||||
|
||||
@ -475,7 +475,7 @@ pgCEditR tid ssh csh = do
|
||||
-- | since an edit is identified via cfCourseId which is not contained in the received form data for security reasons!
|
||||
courseEditHandler :: (forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)) -> Maybe CourseForm -> Handler Html
|
||||
courseEditHandler miButtonAction mbCourseForm = do
|
||||
aid <- requireAuthId -- TODO: Verify that Editor is owner of the Course to be Edited!!!
|
||||
aid <- requireAuthId
|
||||
((result, formWidget), formEnctype) <- runFormPost $ makeCourseForm miButtonAction mbCourseForm
|
||||
formResult result $ \case
|
||||
res@CourseForm
|
||||
|
||||
@ -12,6 +12,7 @@ module Handler.LMS
|
||||
, getLmsUserlistUploadR , postLmsUserlistUploadR, postLmsUserlistDirectR
|
||||
, getLmsResultR , postLmsResultR
|
||||
, getLmsResultUploadR , postLmsResultUploadR , postLmsResultDirectR
|
||||
, getLmsFakeR , postLmsFakeR
|
||||
)
|
||||
where
|
||||
|
||||
@ -37,6 +38,7 @@ import Database.Esqueleto.Utils.TH
|
||||
import Handler.LMS.Users as Handler.LMS
|
||||
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!
|
||||
|
||||
-- avoids repetition of local definitions
|
||||
single :: (k,a) -> Map k a
|
||||
@ -223,9 +225,9 @@ instance Csv.DefaultOrdered LmsTableCsv where
|
||||
|
||||
instance CsvColumnsExplained LmsTableCsv where
|
||||
csvColumnsExplanations = genericCsvColumnsExplanations ltcOptions $ Map.fromList
|
||||
[ ('ltcDisplayName, MsgTableLmsUser)
|
||||
[ ('ltcDisplayName, MsgLmsUser)
|
||||
, ('ltcEmail , MsgTableLmsEmail)
|
||||
, ('ltcValidUntil , MsgTableQualificationValidUntil)
|
||||
, ('ltcValidUntil , MsgLmsQualificationValidUntil)
|
||||
, ('ltcLastRefresh, MsgTableQualificationLastRefresh)
|
||||
, ('ltcFirstHeld , MsgTableQualificationFirstHeld)
|
||||
, ('ltcLmsIdent , MsgTableLmsIdent)
|
||||
@ -356,7 +358,7 @@ mkLmsTable (Entity qid quali) acts restrict cols psValidator = do
|
||||
)
|
||||
]
|
||||
dbtFilterUI mPrev = mconcat
|
||||
[ fltrUserNameEmailHdrUI MsgTableLmsUser mPrev
|
||||
[ 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 "validity" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsValid)
|
||||
@ -434,9 +436,9 @@ postLmsR sid qsh = do
|
||||
]
|
||||
colChoices = mconcat
|
||||
[ dbSelectIf (applying _2) id (return . view (resultUser . _entityKey)) (\r -> isJust $ r ^? resultLmsUser) -- TODO: refactor using function "is"
|
||||
, colUserNameLinkHdr MsgTableLmsUser AdminUserR
|
||||
, colUserNameLinkHdr MsgLmsUser AdminUserR
|
||||
, colUserEmail
|
||||
, sortable (Just "valid-until") (i18nCell MsgTableQualificationValidUntil) $ \( view $ resultQualUser . _entityVal . _qualificationUserValidUntil -> d) -> dayCell d
|
||||
, 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
|
||||
, sortable (Just "lms-ident") (i18nLms MsgTableLmsIdent) $ \(preview $ resultLmsUser . _entityVal . _lmsUserIdent . _getLmsIdent -> lid) -> foldMap textCell lid
|
||||
@ -449,7 +451,7 @@ postLmsR sid qsh = do
|
||||
where
|
||||
-- i18nLms :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a
|
||||
i18nLms msg = cell [whamlet|LMS #|] <> i18nCell msg
|
||||
psValidator = def
|
||||
psValidator = def -- TODO: hier einen Filter für Schützlinge einbauen
|
||||
tbl <- mkLmsTable qent acts (const E.true) colChoices psValidator
|
||||
return (tbl, qent)
|
||||
|
||||
|
||||
159
src/Handler/LMS/Fake.hs
Normal file
159
src/Handler/LMS/Fake.hs
Normal file
@ -0,0 +1,159 @@
|
||||
module Handler.LMS.Fake
|
||||
( getLmsFakeR, postLmsFakeR
|
||||
) where
|
||||
|
||||
import Import
|
||||
|
||||
import Handler.Utils
|
||||
import System.Random (randomRIO)
|
||||
|
||||
import Data.List (cycle)
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.Text.Encoding as TEnc
|
||||
import qualified Yesod.Auth.Util.PasswordStore as PWStore
|
||||
import Control.Applicative (ZipList(..), getZipList)
|
||||
|
||||
|
||||
|
||||
getLmsFakeR, postLmsFakeR :: SchoolId -> QualificationShorthand -> Handler Html
|
||||
getLmsFakeR = postLmsFakeR
|
||||
postLmsFakeR sid qsh = do
|
||||
qent <- runDB $ getBy404 $ SchoolQualificationShort sid qsh
|
||||
now <- liftIO getCurrentTime
|
||||
let qName :: Text = CI.original $ unSchoolKey sid <> "-" <> qsh
|
||||
((fakeRes, fakeView), fakeEnctype) <- runFormPost $ renderAForm FormStandard $ mkFakeForm $ utctDay now
|
||||
let fakeForm = wrapForm fakeView def { formEncoding = fakeEnctype }
|
||||
formResult fakeRes $ \res -> do
|
||||
(uNew, uTotal) <- runDB $ fakeQualificationUsers qent res
|
||||
let msgStatus = if | uNew == 0 -> Error
|
||||
| uNew == uTotal -> Success
|
||||
| otherwise -> Warning
|
||||
addMessage msgStatus $ toHtml $ tshow uNew <> " von " <> tshow uTotal <> " neue Testnutzer mit ablaufender Qualifikation " <> qName <> " generiert"
|
||||
redirect $ LmsR sid qsh
|
||||
siteLayout "Testnutzer generieren" $ do
|
||||
setTitle $ toHtml $ "Testnutzer generieren " <> qName
|
||||
toWidget [whamlet|
|
||||
Hier können zufällige Testbenutzer mit ablaufenden Qualifikationen generiert werden,
|
||||
welche dann im angegebenen Zeitraum fällig werden.
|
||||
|
||||
^{fakeForm}
|
||||
|
||||
<h2>Hinweise:
|
||||
<ul>
|
||||
<li> Emails der generierten Teilnehmer enden auf <tt>@example.com</tt>
|
||||
und die Matrikelnummer lautet <tt>TESTUSER</tt>.
|
||||
<li> Bereits vorhandene Teilnehmer mit gleicher Ident werden nicht neu generiert.
|
||||
<li> Vorhandene Qualifikationen solcher Teilnehmer werden einfach überschrieben.
|
||||
|]
|
||||
|
||||
mkFakeForm :: Day -> AForm Handler (Int, Day, Day)
|
||||
mkFakeForm d = (,,)
|
||||
<$> areq intField (fsl "Fällige Teilnehmer pro Tag") (Just 10)
|
||||
<*> areq dayField (fsl "Erster Tag an dem Teilnehmer fällig werden") (Just d)
|
||||
<*> areq dayField (fsl "Letzter Tag an dem Teilnehmer fällig werden") (Just $ addDays 7 d)
|
||||
|
||||
|
||||
fakeQualificationUsers :: Entity Qualification -> (Int, Day, Day) -> DB (Int,Int)
|
||||
fakeQualificationUsers (Entity qid Qualification{qualificationRefreshWithin}) (usersPerDay, dfrom, dto) = do
|
||||
now <- liftIO getCurrentTime
|
||||
dropNames <- liftIO $ randomRIO (0,length givenNames * length surnames)
|
||||
UserDefaultConf{..} <- getsYesod $ view _appUserDefaults
|
||||
pwSimple <- do
|
||||
let pw = "123.456"
|
||||
PWHashConf{..} <- getsYesod $ view _appAuthPWHash
|
||||
pwHash <- liftIO $ PWStore.makePasswordWith pwHashAlgorithm pw pwHashStrength
|
||||
return $ AuthPWHash $ TEnc.decodeUtf8 pwHash
|
||||
let expiryOffsets = concatMap (replicate usersPerDay) [0..(diffDays dto dfrom)]
|
||||
expiryNotifyDay = addGregorianDurationClip (fromMaybe calendarDay qualificationRefreshWithin) dfrom
|
||||
fakeUser :: ([Text], UserSurname, (Maybe Languages, DateTimeFormat, DateTimeFormat, DateTimeFormat), Bool) -> User
|
||||
fakeUser (firstNames, userSurname, (userLanguages, userDateTimeFormat, userDateFormat, userTimeFormat), userPrefersPostal) =
|
||||
let userIdent = CI.mk $ Text.intercalate "." (take 1 firstNames ++ (Text.take 1 <$> drop 1 firstNames) ++ [userSurname]) <> "@example.com"
|
||||
userEmail = userIdent
|
||||
userDisplayEmail = userIdent
|
||||
userDisplayName = Text.unwords $ firstNames <> [userSurname]
|
||||
userMatrikelnummer = Just "TESTUSER"
|
||||
userAuthentication = pwSimple
|
||||
userLastAuthentication = Nothing
|
||||
userCreated = now
|
||||
userLastLdapSynchronisation = Nothing
|
||||
userLdapPrimaryKey = Nothing
|
||||
userTokensIssuedAfter = Nothing
|
||||
userFirstName = Text.unwords firstNames
|
||||
userTitle = Nothing
|
||||
userMaxFavourites = userDefaultMaxFavourites
|
||||
userMaxFavouriteTerms = userDefaultMaxFavourites
|
||||
userTheme = userDefaultTheme
|
||||
userDownloadFiles = userDefaultDownloadFiles
|
||||
userWarningDays = userDefaultWarningDays
|
||||
userExamOfficeGetSynced = userDefaultExamOfficeGetSynced
|
||||
userExamOfficeGetLabels = userDefaultExamOfficeGetLabels
|
||||
userNotificationSettings = def
|
||||
userCsvOptions = def
|
||||
userSex = Nothing
|
||||
userShowSex = userDefaultShowSex
|
||||
userTelephone = Nothing
|
||||
userMobile = Nothing
|
||||
userCompanyPersonalNumber = Nothing
|
||||
userCompanyDepartment = Nothing
|
||||
userPostAddress = postalAddress
|
||||
userPinPassword = Just "tomatenmarmelade"
|
||||
in User{..}
|
||||
|
||||
$logWarnS "FAKEUSER" $ tshow expiryNotifyDay
|
||||
valid <- forM (zip expiryOffsets $ drop dropNames names) $ \(expOffset, user) -> do
|
||||
euid <- insertBy $ fakeUser user
|
||||
if | (Left (Entity _ User{userMatrikelnummer})) <- euid
|
||||
, userMatrikelnummer /= Just "TESTUSER"
|
||||
-> return 0
|
||||
| otherwise -> do
|
||||
let uid = either entityKey id euid
|
||||
qualificationUserUser = uid
|
||||
qualificationUserQualification = qid
|
||||
qualificationUserValidUntil = addDays expOffset expiryNotifyDay
|
||||
qualificationUserFirstHeld = addGregorianMonthsClip (-24) qualificationUserValidUntil
|
||||
qualificationUserLastRefresh = qualificationUserFirstHeld
|
||||
_ <- upsert QualificationUser{..}
|
||||
[ QualificationUserValidUntil =. qualificationUserValidUntil
|
||||
, QualificationUserLastRefresh =. qualificationUserLastRefresh
|
||||
]
|
||||
return $ either (const 0) (const 1) euid
|
||||
-- ok <- insertUnique QualificationUser{..} -- We do not overwrite any existing qualifications, just to be on the save side:
|
||||
-- return $ maybe 0 (const 1) ok
|
||||
return (sum valid, length expiryOffsets)
|
||||
|
||||
where
|
||||
postalAddress = Just $ plaintextToStoredMarkup $ Text.unlines ["Kapazitätsmanagement Airside (AVN-AR2) - FDTest", "Flughafen Frankfurt Main", "60547 Frankfurt am Main"]
|
||||
givenNames = [ "James", "John", "Robert", "Michael"
|
||||
, "William", "David", "Mary", "Richard"
|
||||
, "Joseph", "Thomas", "Charles", "Daniel"
|
||||
, "Matthew", "Patricia", "Jennifer", "Linda"
|
||||
, "Elizabeth", "Barbara", "Anthony", "Donald"
|
||||
, "Mark", "Paul", "Steven", "Andrew"
|
||||
, "Kenneth", "Joshua", "George", "Kevin"
|
||||
, "Brian", "Edward", "Susan", "Ronald"
|
||||
]
|
||||
middlenames = [ Nothing, Nothing, Just ["Tiberius"], Nothing, Just ["Jamesson", "Maria"], Nothing, Just ["Jörg"] ]
|
||||
surnames = [ "Müller", "Smith", "Johnson", "Williams", "Brown"
|
||||
, "Jones", "Miller", "Davis", "Garcia"
|
||||
, "Rodriguez", "Wilson", "Martinez", "Anderson"
|
||||
, "Taylor", "Thomas", "Hernandez", "Moore"
|
||||
, "Martin", "Jackson", "Thompson", "White"
|
||||
, "Lopez", "Lee", "Gonzalez", "Harris"
|
||||
, "Clark", "Lewis", "Robinson", "Walker"
|
||||
, "Perez", "Hall", "Young", "Allen"
|
||||
]
|
||||
someLangs = [ (Just $ Languages ["de-de"] , DateTimeFormat "%a %d %b %Y %T", DateTimeFormat "%a %d.%m.%Y", DateTimeFormat "%T")
|
||||
, (Nothing , DateTimeFormat "%d.%m.%y %R" , DateTimeFormat "%d.%m.%y" , DateTimeFormat "%R")
|
||||
, (Just $ Languages ["en-eu","de"], DateTimeFormat "%a %d %b %Y %T", DateTimeFormat "%b %d %y" , DateTimeFormat "%I:%M %p")
|
||||
, (Just $ Languages ["fr"] , DateTimeFormat "%d-%m-%Y %R" , DateTimeFormat "%d-%m-%Y" , DateTimeFormat "%R")
|
||||
, (Just $ Languages ["fr","en"] , DateTimeFormat "%B %d %Y %R" , DateTimeFormat "%B %d %y" , DateTimeFormat "%I:%M:%S %p")
|
||||
]
|
||||
postal = [False, True, False]
|
||||
|
||||
names = getZipList $ (\f m s l p -> (f : concat m, s, l, p))
|
||||
<$> ZipList (cycle givenNames)
|
||||
<*> ZipList (cycle middlenames)
|
||||
<*> ZipList (cycle surnames)
|
||||
<*> ZipList (cycle someLangs)
|
||||
<*> ZipList (cycle postal)
|
||||
@ -11,8 +11,8 @@ import Import
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Map as Map
|
||||
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Lazy as LT
|
||||
-- import qualified Data.Text as T
|
||||
-- import qualified Data.Text.Lazy as LT
|
||||
-- import qualified Data.ByteString.Lazy as LBS
|
||||
import qualified Text.Pandoc as P
|
||||
import qualified Text.Pandoc.Builder as P
|
||||
@ -83,7 +83,7 @@ validateMetaPinRenewal = do
|
||||
|
||||
|
||||
mprToMeta :: MetaPinRenewal -> P.Meta
|
||||
mprToMeta MetaPinRenewal{..} = P.Meta $ mconcat
|
||||
mprToMeta MetaPinRenewal{..} = mkMeta
|
||||
-- formatTimeUser SelFormatDate mppDate mppRecipient
|
||||
[ toMeta "recipient" mppRecipient
|
||||
, toMeta "address" (mppRecipient : (mppAddress & html2textlines))
|
||||
@ -98,13 +98,7 @@ mprToMeta MetaPinRenewal{..} = P.Meta $ mconcat
|
||||
where
|
||||
deOrEn = if isDe mppLang then "de" else "en"
|
||||
keyOpening = deOrEn <> "-opening"
|
||||
keyClosing = deOrEn <> "-closing"
|
||||
mbMeta :: P.ToMetaValue a => Text -> Maybe a -> Map Text P.MetaValue
|
||||
mbMeta = foldMap . toMeta
|
||||
toMeta :: P.ToMetaValue a => Text -> a -> Map Text P.MetaValue
|
||||
toMeta k = singletonMap k . P.toMetaValue
|
||||
html2textlines :: StoredMarkup -> [Text]
|
||||
html2textlines sm = T.lines . LT.toStrict $ markupInput sm
|
||||
keyClosing = deOrEn <> "-closing"
|
||||
|
||||
mprToMetaUser :: (MonadHandler m, HandlerSite m ~ UniWorX) => Entity User -> MetaPinRenewal -> m P.Meta
|
||||
mprToMetaUser entUser@Entity{entityVal = u} mpr = do
|
||||
|
||||
@ -178,9 +178,9 @@ mkLmsTable (Entity qid quali) = do
|
||||
dbtRowKey = queryUser >>> (E.^. UserId)
|
||||
dbtProj = dbtProjFilteredPostId -- TODO: or dbtProjSimple what is the difference?
|
||||
dbtColonnade = dbColonnade $ mconcat
|
||||
[ colUserNameLinkHdr MsgTableLmsUser AdminUserR
|
||||
[ colUserNameLinkHdr MsgLmsUser AdminUserR
|
||||
, colUserEmail
|
||||
, sortable (Just "valid-until") (i18nCell MsgTableQualificationValidUntil) $ \( view $ resultQualUser . _entityVal . _qualificationUserValidUntil -> d) -> dayCell d
|
||||
, 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
|
||||
, sortable (Just "lms-ident") (i18nLms MsgTableLmsIdent) $ \(preview $ resultLmsUser . _entityVal . _lmsUserIdent . _getLmsIdent -> lid) -> foldMap textCell lid
|
||||
@ -219,7 +219,7 @@ mkLmsTable (Entity qid quali) = do
|
||||
)
|
||||
]
|
||||
dbtFilterUI mPrev = mconcat
|
||||
[ fltrUserNameEmailHdrUI MsgTableLmsUser mPrev
|
||||
[ 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 "validity" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsValid)
|
||||
|
||||
@ -23,6 +23,9 @@ data AdminUserForm = AdminUserForm
|
||||
, aufTelephone :: Maybe Text
|
||||
, aufFPersonalNumber :: Maybe Text
|
||||
, aufFDepartment :: Maybe Text
|
||||
, aufPostAddress :: Maybe StoredMarkup
|
||||
, aufPrefersPostal :: Bool
|
||||
, aufPinPassword :: Maybe Text
|
||||
, aufEmail :: UserEmail
|
||||
, aufIdent :: UserIdent
|
||||
, aufAuth :: AuthenticationKind
|
||||
@ -56,11 +59,14 @@ adminUserForm template = renderAForm FormStandard
|
||||
<*> aopt (textField & cfStrip) (fslI MsgAdminUserMobile) (aufMobile <$> template)
|
||||
<*> aopt (textField & cfStrip) (fslI MsgAdminUserTelephone) (aufTelephone <$> template)
|
||||
<*> aopt (textField & cfStrip) (fslI MsgAdminUserFPersonalNumber) (aufFPersonalNumber <$> template)
|
||||
<*> aopt (textField & cfStrip) (fslI MsgAdminUserFDepartment) (aufFDepartment <$> template)
|
||||
<*> aopt (textField & cfStrip) (fslI MsgAdminUserFDepartment) (aufFDepartment <$> template)
|
||||
<*> aopt htmlField (fslI MsgAdminUserPostAddress) (aufPostAddress <$> template)
|
||||
<*> areq checkBoxField (fslI MsgAdminUserPrefersPostal) (aufPrefersPostal <$> template)
|
||||
<*> aopt (textField & cfStrip) (fslI MsgAdminUserPinPassword) (aufPinPassword <$> template)
|
||||
<*> areq (emailField & cfCI) (fslI MsgAdminUserEmail) (aufEmail <$> template)
|
||||
<*> areq (textField & cfStrip & cfCI) (fslI MsgAdminUserIdent) (aufIdent <$> template)
|
||||
<*> areq (selectField optionsFinite) (fslI MsgAdminUserAuth) (aufAuth <$> template <|> Just AuthKindLDAP)
|
||||
|
||||
|
||||
|
||||
getAdminUserAddR, postAdminUserAddR :: Handler Html
|
||||
getAdminUserAddR = postAdminUserAddR
|
||||
@ -103,7 +109,10 @@ postAdminUserAddR = do
|
||||
, userMobile = aufMobile
|
||||
, userTelephone = aufTelephone
|
||||
, userCompanyPersonalNumber = aufFPersonalNumber
|
||||
, userCompanyDepartment = aufFDepartment
|
||||
, userCompanyDepartment = aufFDepartment
|
||||
, userPostAddress = aufPostAddress
|
||||
, userPrefersPostal = aufPrefersPostal
|
||||
, userPinPassword = aufPinPassword
|
||||
, userMatrikelnummer = aufMatriculation
|
||||
, userAuthentication = mkAuthMode aufAuth
|
||||
}
|
||||
|
||||
@ -13,3 +13,4 @@ determineSystemFunctions ldapFuncs = \case
|
||||
SystemFaculty -> "CN=PROJ-Fahrerausbildung Admin_rw,OU=Projekte,OU=Sicherheitsgruppen,DC=fra,DC=fraport,DC=de" `Set.member` ldapFuncs -- Fahrerausbildungadmins are lecturers
|
||||
-- SJ: not sure this LDAP-specific key belongs here?
|
||||
SystemStudent -> False -- "student" `Set.member` ldapFuncs -- no such key identified at FraPort
|
||||
SystemPrinter -> False -- "department=IFM-IS2" zu viele Mitglieder
|
||||
|
||||
@ -1,5 +1,7 @@
|
||||
module Handler.Utils.Profile
|
||||
( validDisplayName
|
||||
( checkDisplayName
|
||||
, validDisplayName
|
||||
, fixDisplayName
|
||||
) where
|
||||
|
||||
import Import.NoFoundation
|
||||
@ -8,7 +10,18 @@ import qualified Data.Text as Text
|
||||
import qualified Data.MultiSet as MultiSet
|
||||
import qualified Data.Set as Set
|
||||
|
||||
-- | remove last comma and swap order of the two parts, ie. transforming "surname, givennames" into "givennames surname".
|
||||
-- Input "givennames surname" is left unchanged, except for removing excess whitespace
|
||||
fixDisplayName :: UserDisplayName -> UserDisplayName
|
||||
fixDisplayName udn =
|
||||
let (Text.strip . Text.dropEnd 1 -> surname, Text.strip -> firstnames) = Text.breakOnEnd "," udn
|
||||
in Text.strip $ firstnames <> Text.cons ' ' surname
|
||||
|
||||
-- | Like `validDisplayName` but may return an automatically corrected name
|
||||
checkDisplayName :: Maybe UserTitle -> UserFirstName -> UserSurname -> UserDisplayName -> Maybe UserDisplayName
|
||||
checkDisplayName mTitle fName sName (fixDisplayName -> dName)
|
||||
| validDisplayName mTitle fName sName dName = Just dName
|
||||
| otherwise = Nothing
|
||||
|
||||
validDisplayName :: Maybe UserTitle
|
||||
-> UserFirstName
|
||||
@ -31,7 +44,7 @@ validDisplayName (fmap Text.strip -> mTitle) (Text.strip -> fName) (Text.strip -
|
||||
fNameLetters = Set.fromList $ unpack fName
|
||||
sNameLetters = Set.fromList $ unpack sName
|
||||
dNameLetters = Set.fromList $ unpack dName
|
||||
addLetters = Set.fromList [' ', ',', '.', '-']
|
||||
addLetters = Set.fromList [' ', '.', '-']
|
||||
|
||||
isAdd = (`Set.member` addLetters)
|
||||
splitAdd = Text.split isAdd
|
||||
|
||||
@ -8,6 +8,7 @@ module Handler.Utils.Users
|
||||
, guessUser
|
||||
, UserAssimilateException(..), UserAssimilateExceptionReason(..)
|
||||
, assimilateUser
|
||||
, userPrefersEmail, userPrefersLetter
|
||||
) where
|
||||
|
||||
import Import
|
||||
@ -40,6 +41,13 @@ import qualified Data.Text as Text
|
||||
import Jobs.Types(Job, JobChildren)
|
||||
|
||||
|
||||
userPrefersLetter :: User -> Bool
|
||||
userPrefersLetter User{..} = (userPrefersPostal || Text.null (CI.original userEmail)) && isJust userPostAddress
|
||||
|
||||
userPrefersEmail :: User -> Bool
|
||||
userPrefersEmail = not . userPrefersLetter
|
||||
|
||||
|
||||
computeUserAuthenticationDigest :: AuthenticationMode -> Digest SHA3_256
|
||||
computeUserAuthenticationDigest = hashlazy . JSON.encode
|
||||
|
||||
|
||||
@ -150,7 +150,7 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act
|
||||
pure (quser, luser)
|
||||
let usr_job (quser, luser) =
|
||||
let vold = quser ^. _entityVal . _qualificationUserValidUntil
|
||||
pmonth = fromMonths $ fromMaybe 0 $ qualificationValidDuration quali -- TODO: decide how to deal with qualfication that have infinite validity?!
|
||||
pmonth = fromMonths $ fromMaybe 0 $ qualificationValidDuration quali -- TODO: decide how to deal with qualification that have infinite validity?!
|
||||
vnew = addGregorianDurationClip pmonth vold
|
||||
lmsstatus = luser ^. _entityVal . _lmsUserStatus
|
||||
in case lmsstatus of
|
||||
|
||||
@ -9,10 +9,13 @@ import Import
|
||||
|
||||
import Utils.Print
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Users
|
||||
import Jobs.Handler.SendNotification.Utils
|
||||
|
||||
import qualified Data.ByteString.Lazy as LBS
|
||||
|
||||
import qualified Data.Text as Text
|
||||
|
||||
-- import Handler.Info (FAQItem(..))
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
import Text.Hamlet
|
||||
@ -23,13 +26,17 @@ import Text.Hamlet
|
||||
|
||||
dispatchNotificationQualificationExpiry :: QualificationId -> Day -> UserId -> Handler ()
|
||||
dispatchNotificationQualificationExpiry nQualification _nExpiry jRecipient = userMailT jRecipient $ do
|
||||
(User{..}, Qualification{..}, Entity _ QualificationUser{..}) <- liftHandler . runDB $ (,,)
|
||||
(recipient@User{..}, Qualification{..}, Entity _ QualificationUser{..}) <- liftHandler . runDB $ (,,)
|
||||
<$> getJust jRecipient
|
||||
<*> getJust nQualification
|
||||
<*> getJustBy (UniqueQualificationUser nQualification jRecipient)
|
||||
|
||||
let qname = CI.original qualificationName
|
||||
let entRecipient = Entity jRecipient recipient
|
||||
qname = CI.original qualificationName
|
||||
expiryDate <- formatTimeUser SelFormatDate qualificationUserValidUntil $ Just entRecipient
|
||||
|
||||
$logDebugS "LMS" $ "Notify " <> tshow jRecipient <> " about expiry of qualification " <> qname
|
||||
|
||||
replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
|
||||
setSubjectI $ MsgMailSubjectQualificationExpiry qname
|
||||
|
||||
@ -38,61 +45,71 @@ dispatchNotificationQualificationExpiry nQualification _nExpiry jRecipient = use
|
||||
addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/qualificationExpiry.hamlet")
|
||||
|
||||
|
||||
checkEmailOk :: a -> Bool
|
||||
checkEmailOk = const True -- TODO
|
||||
|
||||
|
||||
-- NOTE: qualificationRenewal expects that LmsUser already exists for recipient
|
||||
dispatchNotificationQualificationRenewal :: QualificationId -> UserId -> Handler ()
|
||||
dispatchNotificationQualificationRenewal nQualification jRecipient = do
|
||||
(User{..}, Qualification{..}, Entity _ QualificationUser{..}) <- runDB $ (,,)
|
||||
(recipient@User{..}, Qualification{..}, Entity _ QualificationUser{..}, Entity _ LmsUser{..}) <- runDB $ (,,,)
|
||||
<$> getJust jRecipient
|
||||
<*> getJust nQualification
|
||||
<*> getJustBy (UniqueQualificationUser nQualification jRecipient)
|
||||
let qname = CI.original qualificationName
|
||||
-- content = $(i18nWidgetFile "qualification/renewal")
|
||||
<*> getJustBy (UniqueQualificationUser nQualification jRecipient)
|
||||
<*> getJustBy (UniqueLmsQualificationUser nQualification jRecipient)
|
||||
let entRecipient = Entity jRecipient recipient
|
||||
qname = CI.original qualificationName
|
||||
|
||||
$logDebugS "LMS" $ "Notify " <> tshow jRecipient <> " for renewal of qualification " <> qname
|
||||
|
||||
let pdfMeta = applyMetas
|
||||
[ ("recipient", userDisplayName)
|
||||
-- TODO: add more info to interpolate here!
|
||||
] mempty
|
||||
now <- liftIO getCurrentTime
|
||||
letterDate <- formatTimeUser SelFormatDate now $ Just entRecipient
|
||||
expiryDate <- formatTimeUser SelFormatDate qualificationUserValidUntil $ Just entRecipient
|
||||
|
||||
let prepAddress upa = userDisplayName : (upa & html2textlines) -- TODO: use supervisor's address
|
||||
pdfMeta = mkMeta
|
||||
[ toMeta "date" letterDate
|
||||
, toMeta "lang" (selectDeEn userLanguages) -- select either German or English only, see Utils.Lang
|
||||
, toMeta "login" (lmsUserIdent & getLmsIdent)
|
||||
, toMeta "pin" lmsUserPin
|
||||
, toMeta "recipient" userDisplayName
|
||||
, mbMeta "address" (prepAddress <$> userPostAddress)
|
||||
, toMeta "expiry" expiryDate
|
||||
, mbMeta "validduration" (show <$> qualificationValidDuration)
|
||||
]
|
||||
pdfRenewal pdfMeta >>= \case
|
||||
Left err -> do
|
||||
let msg = "Notify " <> tshow jRecipient <> " PDF generation failed with error: " <> err
|
||||
$logErrorS "LMS" msg
|
||||
error $ unpack msg
|
||||
Right pdf | checkEmailOk userEmail -> userMailT jRecipient $ do
|
||||
|
||||
replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
|
||||
setSubjectI $ MsgMailSubjectQualificationRenewal qname
|
||||
|
||||
editNotifications <- mkEditNotifications jRecipient -- TODO: add to hamlet file again
|
||||
-- let msgrenewal = $(i18nHamletFile "qualification/renewal") -- :: HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX)
|
||||
-- addHtmlMarkdownAlternatives' msgrenewal
|
||||
|
||||
now <- liftIO getCurrentTime
|
||||
encryptPDF "tomatenmarmelade" pdf >>= \case
|
||||
Left err -> do
|
||||
let msg = "Notify " <> tshow jRecipient <> " PDF encryption failed with error: " <> err
|
||||
$logErrorS "LMS" msg
|
||||
error $ unpack msg
|
||||
Right pdffile -> do
|
||||
addPart (File { fileTitle = "RenewalPinLetter.pdf" -- TODO: better file title!
|
||||
, fileModified = now
|
||||
, fileContent = Just $ yield $ LBS.toStrict pdffile
|
||||
} :: PureFile)
|
||||
-- TODO: this is just a dummy to continue while i18nHamletFile usage is unclear
|
||||
addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/qualificationRenewal.hamlet")
|
||||
|
||||
Right pdf | otherwise -> do
|
||||
let printJobName = mempty --TODO
|
||||
printSender = Nothing --TODO
|
||||
runDB (sendLetter printJobName pdf printSender (Just jRecipient) Nothing (Just nQualification)) >>= \case
|
||||
-- lprPDF printJobName pdf >>= \case
|
||||
Right pdf | userPrefersLetter recipient -> do
|
||||
let printJobName = "Renewal"
|
||||
printSender = Nothing
|
||||
runDB (sendLetter printJobName pdf printSender (Just jRecipient) Nothing (Just nQualification)) >>= \case
|
||||
Left err -> do
|
||||
let msg = "Notify " <> tshow jRecipient <> " PDF printing to send letter failed with error: " <> err
|
||||
$logErrorS "LMS" msg
|
||||
error $ unpack msg
|
||||
Right (msg,_)
|
||||
| null msg -> return ()
|
||||
| otherwise -> $logWarnS "LMS" $ "PDF printing to send letter with lpr returned ExitSucces and the following message: " <> msg
|
||||
| otherwise -> $logWarnS "LMS" $ "PDF printing to send letter with lpr returned ExitSucces and the following message: " <> msg
|
||||
|
||||
Right pdf -> userMailT jRecipient $ do
|
||||
-- userPrefersLetter is false if both userEmail and userPostAddress are null
|
||||
when (Text.null (CI.original userEmail)) $ $logErrorS "LMS" ("Notify " <> tshow jRecipient <> " failed: no email nor address for user known!")
|
||||
|
||||
replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
|
||||
setSubjectI $ MsgMailSubjectQualificationRenewal qname
|
||||
|
||||
encryptPDF (fromMaybe "tomatenmarmelade" userPinPassword) pdf >>= \case -- TODO
|
||||
Left err -> do
|
||||
let msg = "Notify " <> tshow jRecipient <> " PDF encryption failed with error: " <> err
|
||||
$logErrorS "LMS" msg
|
||||
|
||||
Right pdffile -> do
|
||||
addPart (File { fileTitle = "RenewalPinLetter.pdf" -- TODO: better file title!
|
||||
, fileModified = now
|
||||
, fileContent = Just $ yield $ LBS.toStrict pdffile
|
||||
} :: PureFile)
|
||||
|
||||
editNotifications <- mkEditNotifications jRecipient
|
||||
addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/qualificationRenewal.hamlet")
|
||||
|
||||
|
||||
@ -55,6 +55,7 @@ deriving newtype instance ToSample ExternalApiId
|
||||
-- required Show instances for use of getByJust
|
||||
deriving instance Show (Unique ExamPart)
|
||||
deriving instance Show (Unique QualificationUser)
|
||||
deriving instance Show (Unique LmsUser)
|
||||
|
||||
-- ToMarkup and ToMessage instances for displaying selected database primary keys
|
||||
|
||||
|
||||
@ -25,5 +25,6 @@ import Model.Types.Room as Types
|
||||
import Model.Types.Csv as Types
|
||||
import Model.Types.Upload as Types
|
||||
import Model.Types.Lms as Types
|
||||
import Model.Types.Avs as Types
|
||||
import Model.Types.Communication as Types
|
||||
import Model.Types.SystemMessage as Types
|
||||
|
||||
277
src/Model/Types/Avs.hs
Normal file
277
src/Model/Types/Avs.hs
Normal file
@ -0,0 +1,277 @@
|
||||
{-|
|
||||
Module: Model.Types.Avs
|
||||
Description: Types for interface to AusweisVerwaltungsSystem (AVS)
|
||||
-}
|
||||
|
||||
module Model.Types.Avs
|
||||
( module Model.Types.Avs
|
||||
) where
|
||||
|
||||
import Import.NoModel hiding ((.=))
|
||||
--import Utils.Lens hiding ((.=))
|
||||
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.HashMap.Lazy as HM
|
||||
|
||||
import Data.Aeson
|
||||
import Data.Aeson.Types
|
||||
|
||||
|
||||
-- | Like (.:) but attempts parsing with case-insensitve keys as fallback.
|
||||
-- Note that the type also works for an optional field
|
||||
-- Taken from Data.Aeson.Filthy, which could somehow not be added as a dependency.
|
||||
(.:~) :: FromJSON a => Object -> Text -> Parser a
|
||||
o .:~ key = o .: key <|> maybe empty parseJSON go
|
||||
where go = lookup (Text.toLower key) [(Text.toLower k, v) | (k,v) <- HM.toList o]
|
||||
|
||||
{-
|
||||
-- Like (.:?) but attempts parsing with case-insensitve keys as fallback.
|
||||
(.:?~) :: FromJSON a => Object -> Text -> Parser (Maybe a)
|
||||
o .:?~ key = o .: key <|> maybe empty parseJSON go
|
||||
where go = lookup (Text.toLower key) [(Text.toLower k, v) | (k,v) <- HM.toList o]
|
||||
-}
|
||||
|
||||
-- | `SloppyBool` successfully parses different variations of true/false
|
||||
newtype SloppyBool = SloppyBool { sloppyBool :: Bool }
|
||||
deriving (Bounded, Enum, Eq, Ord, Read, Show, Generic, Typeable)
|
||||
|
||||
instance ToJSON SloppyBool where
|
||||
toJSON (SloppyBool True) = "true"
|
||||
toJSON _ = "false"
|
||||
|
||||
instance FromJSON SloppyBool where
|
||||
parseJSON (Bool b) = pure $ SloppyBool b
|
||||
parseJSON (String t)
|
||||
| lowb == "true" = true
|
||||
| lowb == "t" = true
|
||||
| lowb == "f" = false
|
||||
| lowb == "false" = false
|
||||
where lowb = Text.toLower $ Text.strip t
|
||||
true = pure $ SloppyBool True
|
||||
false = pure $ SloppyBool False
|
||||
parseJSON invalid = prependFailure "parsing SloppyBool failed, " $ fail $ "expected Bool or String encoding boolean. Found " ++ show invalid
|
||||
|
||||
|
||||
type AvsPersonId = Int
|
||||
|
||||
|
||||
type AvsLicence = Char
|
||||
licenceVorfeld :: AvsLicence
|
||||
licenceVorfeld = 'F'
|
||||
licenceRollfeld :: AvsLicence
|
||||
licenceRollfeld = 'R'
|
||||
|
||||
|
||||
data AvsDataCardColor = AvsCardColorGrün | AvsCardColorBlau | AvsCardColorRot | AvsCardColorGelb | AvsCardColorMisc Text
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
|
||||
instance ToJSON AvsDataCardColor where
|
||||
toJSON AvsCardColorGrün = "Grün"
|
||||
toJSON AvsCardColorBlau = "Blau"
|
||||
toJSON AvsCardColorRot = "Rot"
|
||||
toJSON AvsCardColorGelb = "Gelb"
|
||||
toJSON (AvsCardColorMisc t) = String t
|
||||
|
||||
instance FromJSON AvsDataCardColor where
|
||||
parseJSON (String t) = case Text.toLower t of
|
||||
"grün" -> pure AvsCardColorGrün
|
||||
"blau" -> pure AvsCardColorBlau
|
||||
"rot" -> pure AvsCardColorRot
|
||||
"gelb" -> pure AvsCardColorGelb
|
||||
_ -> pure $ AvsCardColorMisc t
|
||||
parseJSON invalid = prependFailure "parsing AvsDataCardColor failed, " (typeMismatch "String" invalid)
|
||||
|
||||
data AvsDataPersonCard = AvsDataPersonCard
|
||||
{ avsDataValid :: Bool -- card currently valid? Note that AVS encodes booleans as JSON String "true" and "false" and not as JSON booleans
|
||||
, avsDataValidTo :: Maybe Day -- always Nothing if returned with AvsResponseStatus
|
||||
, avsDataIssueDate :: Maybe Day -- always Nothing if returned with AvsResponseStatus
|
||||
, avsDataCardAreas :: Set Char -- logically a set of upper-case letters
|
||||
, avsDataStreet :: Maybe Text -- always Nothing if returned with AvsResponseStatus
|
||||
, avsDataPostalCode:: Maybe Text -- always Nothing if returned with AvsResponseStatus
|
||||
, avsDataCity :: Maybe Text -- always Nothing if returned with AvsResponseStatus
|
||||
, avsDataFirm :: Maybe Text -- always Nothing if returned with AvsResponseStatus
|
||||
, avsDataCardColor :: AvsDataCardColor
|
||||
, avsDataCardNo :: Text -- always 8 digits
|
||||
, avsDataVersionNo :: Text
|
||||
}
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
|
||||
{- Automatically derived Ord instance should prioritize avsDataValid and avsDataValidTo. Checked in test/Model.TypesSpec
|
||||
instance Ord AvsDataPersonCard where
|
||||
compare a b =
|
||||
compareBy avsDataValid
|
||||
<> compareBy avsDataValidTo
|
||||
<> compareBy avsDataIssueDate
|
||||
<> compareBy avsDataCardAreas
|
||||
...
|
||||
where
|
||||
compareBy f = compare `on` f a b
|
||||
-}
|
||||
|
||||
{- Instead of programming entirely by hand, why not dump splices and adjust? -}
|
||||
instance FromJSON AvsDataPersonCard where
|
||||
parseJSON = withObject "AvsDataPersonCard" $ \v -> AvsDataPersonCard
|
||||
<$> ((v .: "Valid") <&> sloppyBool)
|
||||
<*> v .:? "ValidTo"
|
||||
<*> v .:? "IssueDate"
|
||||
<*> ((v .: "CardAreas") <&> charSet)
|
||||
<*> v .:? "Street"
|
||||
<*> v .:? "PostalCode"
|
||||
<*> v .:? "City"
|
||||
<*> v .:? "Firm"
|
||||
<*> v .: "CardColor"
|
||||
<*> v .: "CardNo"
|
||||
<*> v .: "VersionNo"
|
||||
|
||||
instance ToJSON AvsDataPersonCard where
|
||||
toJSON AvsDataPersonCard{..} = object
|
||||
[ "CardAreas" .= Set.foldl Text.snoc Text.empty avsDataCardAreas
|
||||
, "CardColor" .= avsDataCardColor
|
||||
, "CardNo" .= avsDataCardNo
|
||||
, "VersionNo" .= avsDataVersionNo
|
||||
, "Valid" .= show avsDataValid
|
||||
, "ValidTo" .= avsDataValidTo
|
||||
, "IssueDate" .= avsDataIssueDate
|
||||
, "Firm" .= avsDataFirm
|
||||
, "City" .= avsDataCity
|
||||
, "Street" .= avsDataStreet
|
||||
, "PostalCode" .= avsDataPostalCode
|
||||
]
|
||||
|
||||
data AvsStatusPerson = AvsStatusPerson
|
||||
{ avsStatusPersonID :: AvsPersonId
|
||||
, avsStatusPersonCardStatus :: Set AvsDataPersonCard
|
||||
}
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
|
||||
|
||||
deriveJSON defaultOptions
|
||||
{ fieldLabelModifier = \case { "avsStatusPersonCardStatus" -> "personCardStatus"; others -> dropCamel 2 others }
|
||||
, omitNothingFields = True
|
||||
, tagSingleConstructors = False
|
||||
, rejectUnknownFields = False
|
||||
} ''AvsStatusPerson
|
||||
|
||||
data AvsDataPerson = AvsDataPerson
|
||||
{ avsPersonFirstName :: Text
|
||||
, avsPersonLastName :: Text
|
||||
, avsPersonInternalPersonalNo :: Maybe Text -- Fraport Personalnummer
|
||||
, avsPersonPersonNo :: AvsPersonId -- AVS Personennummer
|
||||
, avsPersonPersonID :: AvsPersonId -- Eindeutige PersonenID, wichtig für die Schnittstelle!
|
||||
, avsPersonPersonCards :: Set AvsDataPersonCard
|
||||
}
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
|
||||
deriveJSON defaultOptions
|
||||
{ fieldLabelModifier = \case { "avsPersonPersonCards" -> "personCards"; others -> dropCamel 2 others }
|
||||
, omitNothingFields = True
|
||||
, tagSingleConstructors = False
|
||||
, rejectUnknownFields = False
|
||||
} ''AvsDataPerson
|
||||
|
||||
|
||||
|
||||
--------------
|
||||
-- Responses --
|
||||
---------------
|
||||
|
||||
newtype AvsResponseStatus = AvsResponseStatus (Set AvsStatusPerson)
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
deriveJSON defaultOptions
|
||||
{ fieldLabelModifier = dropCamel 2
|
||||
, omitNothingFields = True
|
||||
, tagSingleConstructors = False
|
||||
, rejectUnknownFields = False
|
||||
} ''AvsResponseStatus
|
||||
|
||||
newtype AvsResponsePerson = AvsResponsePerson (Set AvsDataPerson)
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
deriveJSON defaultOptions
|
||||
{ fieldLabelModifier = dropCamel 2
|
||||
, omitNothingFields = True
|
||||
, tagSingleConstructors = False
|
||||
, rejectUnknownFields = False
|
||||
} ''AvsResponsePerson
|
||||
|
||||
-------------
|
||||
-- Queries --
|
||||
-------------
|
||||
data AvsQueryPerson = AvsQueryPerson
|
||||
{ avsPersonQueryCardNo :: Maybe Text
|
||||
, avsPersonQueryFirstName :: Maybe Text
|
||||
, avsPersonQueryLastName :: Maybe Text
|
||||
, avsPersonQueryInternalPersonalNo :: Maybe Text
|
||||
, avsPersonQueryVersionNo :: Maybe Text
|
||||
}
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
|
||||
instance Default AvsQueryPerson where
|
||||
def = AvsQueryPerson Nothing Nothing Nothing Nothing Nothing
|
||||
|
||||
deriveJSON defaultOptions
|
||||
{ fieldLabelModifier = dropCamel 3
|
||||
, omitNothingFields = True
|
||||
, tagSingleConstructors = False
|
||||
, rejectUnknownFields = False
|
||||
} ''AvsQueryPerson
|
||||
|
||||
newtype AvsQueryStatus = AvsQueryStatus (Set AvsPersonId)
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
deriveJSON defaultOptions ''AvsQueryStatus
|
||||
|
||||
|
||||
-----------------------
|
||||
-- Utility Functions --
|
||||
-----------------------
|
||||
|
||||
-- | retrieve AvsDataPersonCard with longest validity for a given licence,
|
||||
-- first argument is a lower bound for avsDataValidTo, usually current day
|
||||
-- Note that avsDataValidTo is Nothing if retrieved via AvsResponseStatus (simply use isJust on result in this case)
|
||||
getValidLicence :: Maybe Day -> AvsLicence -> Set AvsDataPersonCard -> Maybe AvsDataPersonCard
|
||||
getValidLicence cutoff licence cards = Set.lookupMax validLicenceCards
|
||||
where
|
||||
validLicenceCards = Set.filter cardMatch cards
|
||||
cardMatch AvsDataPersonCard{..} =
|
||||
avsDataValid && (avsDataValidTo >= cutoff) && (licence `Set.member` avsDataCardAreas)
|
||||
|
||||
guessLicencseAddress :: Set AvsDataPersonCard -> Maybe Text
|
||||
guessLicencseAddress cards
|
||||
| Just c <- Set.lookupMax cards
|
||||
, AvsDataPersonCard{..} <- Set.foldr pickLicenceAddress c cards
|
||||
, Just street <- avsDataStreet
|
||||
, Just pcode <- avsDataPostalCode
|
||||
, Just city <- avsDataCity
|
||||
= Just $ Text.unlines [street, Text.unwords [pcode, city]]
|
||||
| otherwise = Nothing
|
||||
|
||||
hasAddress :: AvsDataPersonCard -> Bool
|
||||
hasAddress AvsDataPersonCard{..} = isJust avsDataStreet && isJust avsDataCity && isJust avsDataPostalCode
|
||||
|
||||
pickLicenceAddress :: AvsDataPersonCard -> AvsDataPersonCard -> AvsDataPersonCard
|
||||
pickLicenceAddress a b
|
||||
| Just r <- pickBetter' hasAddress = r -- prefer card with complete address
|
||||
| Just r <- pickBetter' avsDataValid = r -- prefer valid cards
|
||||
| Just r <- pickBetter' (Set.member licenceRollfeld . avsDataCardAreas) = r -- prefer 'R' cards
|
||||
| Just r <- pickBetter' (Set.member licenceVorfeld . avsDataCardAreas) = r -- prefer 'F' cards
|
||||
| avsDataIssueDate a > avsDataIssueDate b = a -- prefer later issue date
|
||||
| avsDataIssueDate a < avsDataIssueDate b = b
|
||||
| avsDataValidTo a > avsDataValidTo b = a -- prefer later validto date
|
||||
| avsDataValidTo a < avsDataValidTo b = b
|
||||
| Just r <- pickBetter' (isJust . avsDataFirm) = r -- prefer having a firm
|
||||
| a <= b = b -- respect natural Ord instance
|
||||
| otherwise = a
|
||||
where
|
||||
pickBetter' :: (AvsDataPersonCard -> Bool) -> Maybe AvsDataPersonCard
|
||||
pickBetter' = pickBetter a b
|
||||
|
||||
{- Note:
|
||||
For Semigroup Ordering, (<>) ignores the righthand side except for EQ; this can be conveniently be used like so
|
||||
bestAddress :: AvsDataPersonCard -> AvsDataPersonCard -> Ordering
|
||||
compare a b = compareBy avsDataValid
|
||||
<> compareBy avsDataValidTo
|
||||
<> compareBy avsDataIssueDate
|
||||
...
|
||||
where
|
||||
compareBy f = compare `on` f a b
|
||||
-}
|
||||
@ -12,7 +12,7 @@ import Model.Types.TH.JSON
|
||||
import Control.Lens.TH (makeWrapped)
|
||||
|
||||
|
||||
newtype Languages = Languages [Lang]
|
||||
newtype Languages = Languages { getLanguages :: [Lang] }
|
||||
deriving (Eq, Ord, Show, Read, Generic, Typeable)
|
||||
deriving newtype (FromJSON, ToJSON, IsList)
|
||||
|
||||
|
||||
@ -5,7 +5,8 @@ module Model.Types.Markup
|
||||
, markdownToStoredMarkup
|
||||
, esqueletoMarkupOutput
|
||||
, I18nStoredMarkup
|
||||
, markupIsSmallish
|
||||
, markupIsSmallish
|
||||
, html2textlines
|
||||
) where
|
||||
|
||||
import Import.NoModel
|
||||
@ -148,4 +149,8 @@ type I18nStoredMarkup = I18n StoredMarkup
|
||||
|
||||
-- | determine whether the StoredMarkup is small-ish
|
||||
markupIsSmallish :: StoredMarkup -> Bool
|
||||
markupIsSmallish StoredMarkup{markupInput} = GT /= LT.compareLength markupInput 32
|
||||
markupIsSmallish StoredMarkup{markupInput} = GT /= LT.compareLength markupInput 32
|
||||
|
||||
|
||||
html2textlines :: StoredMarkup -> [Text]
|
||||
html2textlines sm = LT.toStrict <$> LT.lines (markupInput sm)
|
||||
|
||||
@ -75,6 +75,7 @@ data AuthTag -- sortiert nach gewünschter Reihenfolge auf /authpreds, d.h. Prä
|
||||
| AuthTutorControl
|
||||
| AuthExamOffice
|
||||
| AuthSystemExamOffice
|
||||
| AuthSystemPrinter
|
||||
| AuthEvaluation
|
||||
| AuthAllocationAdmin
|
||||
| AuthAllocationRegistered
|
||||
|
||||
@ -11,6 +11,7 @@ data SystemFunction
|
||||
= SystemExamOffice
|
||||
| SystemFaculty
|
||||
| SystemStudent
|
||||
| SystemPrinter
|
||||
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
|
||||
deriving anyclass (Universe, Finite, Hashable, NFData)
|
||||
|
||||
|
||||
17
src/Utils.hs
17
src/Utils.hs
@ -654,6 +654,11 @@ infixl 5 !!!
|
||||
(!!!) :: (Ord k, Monoid v) => Map k v -> k -> v
|
||||
(!!!) m k = fromMaybe mempty $ Map.lookup k m
|
||||
|
||||
lookupSome :: (Monad m, Ord k, Monoid (m v)) => Map k (m v) -> m k -> m v
|
||||
-- lookupSome :: Ord k => Map k [v] -> [k] -> [v]
|
||||
-- lookupSome m ks = ks >>= (m !!!)
|
||||
lookupSome = (=<<) . (!!!)
|
||||
|
||||
groupMap :: (Ord k, Ord v) => [(k,v)] -> Map k (Set v)
|
||||
groupMap l = Map.fromListWith mappend [(k, Set.singleton v) | (k,v) <- l]
|
||||
|
||||
@ -878,6 +883,7 @@ whenIsRight (Left _) _ = pure ()
|
||||
throwLeft :: (MonadThrow m, Exception exc) => Either exc a -> m a
|
||||
throwLeft = either throwM return
|
||||
|
||||
|
||||
{- Just a reminder for Steffen:
|
||||
mapLeft :: (a -> c) -> Either a b -> Either c b
|
||||
mapLeft = over _Left
|
||||
@ -888,7 +894,7 @@ actLeft (Left x) f = f x
|
||||
actLeft (Right y) _ = pure $ Right y
|
||||
|
||||
-- | like monadic bind for 'Either', but wrapped in another monad
|
||||
-- ok to use once, otherweise better to use 'Control.Monad.Trans.Except' instead
|
||||
-- ok to use once, otherwise better to use 'Control.Monad.Trans.Except' instead
|
||||
actRight :: Applicative f => Either a b -> (b -> f (Either a c)) -> f (Either a c)
|
||||
actRight (Left x) _ = pure $ Left x
|
||||
actRight (Right y) f = f y
|
||||
@ -1578,6 +1584,15 @@ maxOn = maxBy . comparing
|
||||
inBetween:: Ord a => a -> (a,a) -> Bool
|
||||
inBetween x (lower,upper) = lower <= x && x <= upper
|
||||
|
||||
-- | Given to values and a criterion, returns the unique argument that fulfills the criterion, if it exists
|
||||
pickBetter :: a -> a -> (a -> Bool) -> Maybe a
|
||||
pickBetter x y crit
|
||||
| cx == cy = Nothing
|
||||
| cx = Just x
|
||||
| otherwise = Just y
|
||||
where
|
||||
cx = crit x
|
||||
cy = crit y
|
||||
|
||||
------------
|
||||
-- Random --
|
||||
|
||||
194
src/Utils/Avs.hs
194
src/Utils/Avs.hs
@ -3,203 +3,11 @@ module Utils.Avs where
|
||||
import Import.NoModel hiding ((.=))
|
||||
import Utils.Lens hiding ((.=))
|
||||
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.HashMap.Lazy as HM
|
||||
|
||||
import Data.Aeson
|
||||
import Data.Aeson.Types
|
||||
|
||||
import Servant
|
||||
import Servant.Client
|
||||
import Servant.Client.Core (requestPath)
|
||||
|
||||
|
||||
|
||||
-- | Like (.:) but attempts parsing with case-insensitve keys as fallback.
|
||||
-- Note that the type also works for an optional field
|
||||
-- Taken from Data.Aeson.Filthy, which could somehow not be added as a dependency.
|
||||
(.:~) :: FromJSON a => Object -> Text -> Parser a
|
||||
o .:~ key = o .: key <|> maybe empty parseJSON go
|
||||
where go = lookup (Text.toLower key) [(Text.toLower k, v) | (k,v) <- HM.toList o]
|
||||
|
||||
{-
|
||||
-- Like (.:?) but attempts parsing with case-insensitve keys as fallback.
|
||||
(.:?~) :: FromJSON a => Object -> Text -> Parser (Maybe a)
|
||||
o .:?~ key = o .: key <|> maybe empty parseJSON go
|
||||
where go = lookup (Text.toLower key) [(Text.toLower k, v) | (k,v) <- HM.toList o]
|
||||
-}
|
||||
|
||||
newtype SloppyBool = SloppyBool { sloppyBool :: Bool }
|
||||
deriving (Bounded, Enum, Eq, Ord, Read, Show, Generic, Typeable)
|
||||
|
||||
instance ToJSON SloppyBool where
|
||||
toJSON (SloppyBool True) = "true"
|
||||
toJSON _ = "false"
|
||||
|
||||
instance FromJSON SloppyBool where
|
||||
parseJSON (Bool b) = pure $ SloppyBool b
|
||||
parseJSON (String t)
|
||||
| lowb == "true" = true
|
||||
| lowb == "t" = true
|
||||
| lowb == "f" = false
|
||||
| lowb == "false" = false
|
||||
where lowb = Text.toLower $ Text.strip t
|
||||
true = pure $ SloppyBool True
|
||||
false = pure $ SloppyBool False
|
||||
parseJSON invalid = prependFailure "parsing SloppyBool failed, " $ fail $ "expected Bool or String encoding boolean. Found " ++ show invalid
|
||||
|
||||
type AvsPersonId = Int
|
||||
|
||||
data AvsDataCardColor = AvsCardColorGrün | AvsCardColorBlau | AvsCardColorRot | AvsCardColorGelb | AvsCardColorMisc Text
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
|
||||
instance ToJSON AvsDataCardColor where
|
||||
toJSON AvsCardColorGrün = "Grün"
|
||||
toJSON AvsCardColorBlau = "Blau"
|
||||
toJSON AvsCardColorRot = "Rot"
|
||||
toJSON AvsCardColorGelb = "Gelb"
|
||||
toJSON (AvsCardColorMisc t) = String t
|
||||
|
||||
instance FromJSON AvsDataCardColor where
|
||||
parseJSON (String t) = case Text.toLower t of
|
||||
"grün" -> pure AvsCardColorGrün
|
||||
"blau" -> pure AvsCardColorBlau
|
||||
"rot" -> pure AvsCardColorRot
|
||||
"gelb" -> pure AvsCardColorGelb
|
||||
_ -> pure $ AvsCardColorMisc t
|
||||
parseJSON invalid = prependFailure "parsing AvsDataCardColor failed, " (typeMismatch "String" invalid)
|
||||
|
||||
data AvsDataPersonCard = AvsDataPersonCard
|
||||
{ avsDataCardAreas :: Set Char -- logically a set of upper-case letters
|
||||
, avsDataCardColor :: AvsDataCardColor
|
||||
, avsDataCardNo :: Text -- always 8 digits
|
||||
, avsDataVersionNo :: Text
|
||||
, avsDataValid :: Bool -- unfortunately, AVS encodes Booleans as JSON String "true" and "false" and not as JSON Booleans
|
||||
-- only the above are contained in AvsResponseStatus
|
||||
, avsDataValidTo :: Maybe Day
|
||||
, avsDataIssueDate :: Maybe Day
|
||||
, avsDataFirm :: Maybe Text
|
||||
, avsDataCity :: Maybe Text
|
||||
, avsDataStreet :: Maybe Text
|
||||
, avsDataPostalCode:: Maybe Text
|
||||
}
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
|
||||
{- Instead of programming entirely by hand, why not dump splices and adjust? -}
|
||||
instance FromJSON AvsDataPersonCard where
|
||||
parseJSON = withObject "AvsDataPersonCard" $ \v -> AvsDataPersonCard
|
||||
<$> ((v .: "CardAreas") <&> charSet)
|
||||
<*> v .: "CardColor"
|
||||
<*> v .: "CardNo"
|
||||
<*> v .: "VersionNo"
|
||||
<*> ((v .: "Valid") <&> sloppyBool)
|
||||
<*> v .:? "ValidTo"
|
||||
<*> v .:? "IssueDate"
|
||||
<*> v .:? "Firm"
|
||||
<*> v .:? "City"
|
||||
<*> v .:? "Street"
|
||||
<*> v .:? "PostalCode"
|
||||
|
||||
|
||||
instance ToJSON AvsDataPersonCard where
|
||||
toJSON AvsDataPersonCard{..} = object
|
||||
[ "CardAreas" .= Set.foldl Text.snoc Text.empty avsDataCardAreas
|
||||
, "CardColor" .= avsDataCardColor
|
||||
, "CardNo" .= avsDataCardNo
|
||||
, "VersionNo" .= avsDataVersionNo
|
||||
, "Valid" .= show avsDataValid
|
||||
, "ValidTo" .= avsDataValidTo
|
||||
, "IssueDate" .= avsDataIssueDate
|
||||
, "Firm" .= avsDataFirm
|
||||
, "City" .= avsDataCity
|
||||
, "Street" .= avsDataStreet
|
||||
, "PostalCode" .= avsDataPostalCode
|
||||
]
|
||||
|
||||
data AvsStatusPerson = AvsStatusPerson
|
||||
{ avsStatusPersonID :: AvsPersonId
|
||||
, avsStatusPersonCardStatus :: Set AvsDataPersonCard
|
||||
}
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
|
||||
|
||||
deriveJSON defaultOptions
|
||||
{ fieldLabelModifier = \case { "avsStatusPersonCardStatus" -> "personCardStatus"; others -> dropCamel 2 others }
|
||||
, omitNothingFields = True
|
||||
, tagSingleConstructors = False
|
||||
, rejectUnknownFields = False
|
||||
} ''AvsStatusPerson
|
||||
|
||||
data AvsDataPerson = AvsDataPerson
|
||||
{ avsPersonFirstName :: Text
|
||||
, avsPersonLastName :: Text
|
||||
, avsPersonInternalPersonalNo :: Maybe Text -- Fraport Personalnummer
|
||||
, avsPersonPersonNo :: AvsPersonId -- AVS Personennummer
|
||||
, avsPersonPersonID :: AvsPersonId -- Eindeutige PersonenID, wichtig für die Schnittstelle!
|
||||
, avsPersonPersonCards :: Set AvsDataPersonCard
|
||||
}
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
|
||||
deriveJSON defaultOptions
|
||||
{ fieldLabelModifier = \case { "avsPersonPersonCards" -> "personCards"; others -> dropCamel 2 others }
|
||||
, omitNothingFields = True
|
||||
, tagSingleConstructors = False
|
||||
, rejectUnknownFields = False
|
||||
} ''AvsDataPerson
|
||||
|
||||
|
||||
|
||||
--------------
|
||||
-- Responses --
|
||||
---------------
|
||||
|
||||
newtype AvsResponseStatus = AvsResponseStatus (Set AvsStatusPerson)
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
deriveJSON defaultOptions
|
||||
{ fieldLabelModifier = dropCamel 2
|
||||
, omitNothingFields = True
|
||||
, tagSingleConstructors = False
|
||||
, rejectUnknownFields = False
|
||||
} ''AvsResponseStatus
|
||||
|
||||
newtype AvsResponsePerson = AvsResponsePerson (Set AvsDataPerson)
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
deriveJSON defaultOptions
|
||||
{ fieldLabelModifier = dropCamel 2
|
||||
, omitNothingFields = True
|
||||
, tagSingleConstructors = False
|
||||
, rejectUnknownFields = False
|
||||
} ''AvsResponsePerson
|
||||
|
||||
|
||||
|
||||
-------------
|
||||
-- Queries --
|
||||
-------------
|
||||
data AvsQueryPerson = AvsQueryPerson
|
||||
{ avsPersonQueryCardNo :: Maybe Text
|
||||
, avsPersonQueryFirstName :: Maybe Text
|
||||
, avsPersonQueryLastName :: Maybe Text
|
||||
, avsPersonQueryInternalPersonalNo :: Maybe Text
|
||||
, avsPersonQueryVersionNo :: Maybe Text
|
||||
}
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
|
||||
instance Default AvsQueryPerson where
|
||||
def = AvsQueryPerson Nothing Nothing Nothing Nothing Nothing
|
||||
|
||||
deriveJSON defaultOptions
|
||||
{ fieldLabelModifier = dropCamel 3
|
||||
, omitNothingFields = True
|
||||
, tagSingleConstructors = False
|
||||
, rejectUnknownFields = False
|
||||
} ''AvsQueryPerson
|
||||
|
||||
newtype AvsQueryStatus = AvsQueryStatus (Set AvsPersonId)
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
deriveJSON defaultOptions ''AvsQueryStatus
|
||||
|
||||
import Model.Types.Avs
|
||||
|
||||
|
||||
-------------
|
||||
|
||||
@ -2,6 +2,7 @@ module Utils.Lang where
|
||||
|
||||
import ClassyPrelude.Yesod
|
||||
|
||||
import Model.Types.Languages
|
||||
import Utils.Cookies.Registered
|
||||
import Utils.Parameters
|
||||
import Utils.Session
|
||||
@ -31,6 +32,16 @@ isDe = isPrefixOf "de"
|
||||
isEn :: Lang -> Bool
|
||||
isEn = isPrefixOf "en"
|
||||
|
||||
selectDeEn :: Maybe Languages -> Lang
|
||||
selectDeEn = selectLanguage' availableLanguages . concatMap getLanguages
|
||||
where
|
||||
availableLanguages = "de" :| ["en"] -- for now, we only have german and english, with german being the default language
|
||||
|
||||
selectEnDe :: Maybe Languages -> Lang
|
||||
selectEnDe = selectLanguage' availableLanguages . concatMap getLanguages
|
||||
where
|
||||
availableLanguages = "en" :| ["de"]
|
||||
|
||||
selectLanguage :: MonadHandler m
|
||||
=> NonEmpty Lang -- ^ Available translations, first is default
|
||||
-> m Lang
|
||||
|
||||
@ -1,4 +1,16 @@
|
||||
module Utils.Print where
|
||||
{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
|
||||
|
||||
module Utils.Print
|
||||
( pdfRenewal
|
||||
, sendLetter
|
||||
, encryptPDF
|
||||
, templateDIN5008
|
||||
, templateRenewal
|
||||
-- , compileTemplate, makePDF
|
||||
, _Meta, addMeta
|
||||
, toMeta, mbMeta -- single values
|
||||
, mkMeta, appMeta, applyMetas -- multiple values
|
||||
) where
|
||||
|
||||
-- import Import.NoModel
|
||||
import qualified Data.Foldable as Fold
|
||||
@ -38,7 +50,6 @@ templateDIN5008 :: Text
|
||||
templateDIN5008 = decodeUtf8 $(Data.FileEmbed.embedFile "templates/letter/din5008.latex")
|
||||
|
||||
|
||||
|
||||
----------------------
|
||||
-- Pandoc Functions --
|
||||
----------------------
|
||||
@ -68,14 +79,33 @@ _Meta = lens mget mput
|
||||
mget (P.Pandoc m _) = m
|
||||
mput (P.Pandoc _ b) m = P.Pandoc m b
|
||||
|
||||
toMeta :: P.ToMetaValue a => Text -> a -> Map Text P.MetaValue
|
||||
toMeta k = singletonMap k . P.toMetaValue
|
||||
|
||||
mbMeta :: P.ToMetaValue a => Text -> Maybe a -> Map Text P.MetaValue
|
||||
mbMeta = foldMap . toMeta
|
||||
|
||||
-- | For convenience and to avoid importing Pandoc
|
||||
mkMeta :: [Map Text P.MetaValue] -> P.Meta
|
||||
mkMeta = P.Meta . mconcat
|
||||
|
||||
-- | Modify the Meta-Block of Pandoc
|
||||
appMeta :: (P.Meta -> P.Meta) -> P.Pandoc -> P.Pandoc
|
||||
appMeta f (P.Pandoc m bs) = P.Pandoc (f m) bs
|
||||
-- appMeta f = _Meta %~ f -- lens version. Not sure this is better
|
||||
|
||||
|
||||
-- TODO: applyMetas is inconvenient since we cannot have an instance
|
||||
-- ToMetaValue a => ToMetaValue (Maybe a)
|
||||
-- so apply Metas
|
||||
|
||||
-- For tests see module PandocSpec
|
||||
applyMetas :: (P.HasMeta p, Foldable t, P.ToMetaValue a) => t (Text, a) -> p -> p
|
||||
applyMetas metas doc = Fold.foldr (uncurry P.setMeta) doc metas
|
||||
applyMetas :: (P.HasMeta p, Foldable t, P.ToMetaValue a) => t (Text, Maybe a) -> p -> p
|
||||
applyMetas metas doc = Fold.foldr act doc metas
|
||||
where
|
||||
act (_, Nothing) acc = acc
|
||||
act (k, Just v ) acc = P.setMeta k v acc
|
||||
|
||||
|
||||
-- | Add meta to pandoc. Existing variables will be overwritten.
|
||||
-- For specification, see module PandocSpec
|
||||
@ -241,8 +271,8 @@ sendLetter printJobName pdf printJobRecipient printJobSender printJobCourse prin
|
||||
nameCourse = CI.original . courseShorthand <$> course
|
||||
nameQuali = CI.original . qualificationShorthand <$> quali
|
||||
let printJobAcknowledged = Nothing
|
||||
jobFullName = unpack $ T.replace " " "-" (T.intercalate "_" . catMaybes $ [Just printJobName, nameQuali, nameCourse, nameSender, nameRecipient])
|
||||
printJobFilename = jobFullName <> ".pdf"
|
||||
jobFullName = unpack $ T.replace " " "-" (T.intercalate "_" . catMaybes $ [Just printJobName, nameQuali, nameCourse, nameSender, nameRecipient])
|
||||
printJobFilename = jobFullName <> ".pdf"
|
||||
-- printJobFile <- sinkFileDB True $ yield $ LBS.toStrict pdf -- for PrintJobFile :: FileContentReference use this code
|
||||
printJobFile = LBS.toStrict pdf
|
||||
lprPDF jobFullName pdf >>= \case
|
||||
@ -309,15 +339,15 @@ readProcess' pc = do
|
||||
-- > pdftk - output - user_pw tomatenmarmelade
|
||||
--
|
||||
|
||||
encryptPDF :: MonadIO m => String -> LBS.ByteString -> m (Either Text LBS.ByteString)
|
||||
encryptPDF :: MonadIO m => Text -> LBS.ByteString -> m (Either Text LBS.ByteString)
|
||||
encryptPDF pw bs = over _Left (decodeUtf8 . LBS.toStrict) . exit2either <$> readProcess pc
|
||||
where
|
||||
pc = setStdin (byteStringInput bs) $
|
||||
proc "pdftk" [ "-" -- read from stdin
|
||||
, "output", "-" -- write to stdout
|
||||
, "user_pw", pw -- encrypt pdf content
|
||||
, "dont_ask" -- no interaction
|
||||
, "allow", "Printing" -- allow printing despite encryption
|
||||
proc "pdftk" [ "-" -- read from stdin
|
||||
, "output", "-" -- write to stdout
|
||||
, "user_pw", T.unpack pw -- encrypt pdf content
|
||||
, "dont_ask" -- no interaction
|
||||
, "allow", "Printing" -- allow printing despite encryption
|
||||
]
|
||||
-- Note that pdftk will issue a warning, which will be ignored:
|
||||
-- Warning: Using a password on the command line interface can be insecure.
|
||||
@ -335,10 +365,7 @@ encryptPDF pw bs = over _Left (decodeUtf8 . LBS.toStrict) . exit2either <$> read
|
||||
-- The cups version of lpr is instead used like so:
|
||||
-- > lpr -P fradrive -H fravm017173.fra.fraport.de:515 -T printJobName -
|
||||
|
||||
|
||||
-- TODO: consider hiding this function within the export, as it does not create an entry in the printJob table in the DB
|
||||
|
||||
-- | Internal, use `sendLetter` instead
|
||||
-- | Internal only, use `sendLetter` instead
|
||||
lprPDF :: (MonadHandler m, HasAppSettings (HandlerSite m)) => String -> LBS.ByteString -> m (Either Text Text)
|
||||
lprPDF jb bs = do
|
||||
lprServerArg <- $cachedHereBinary ("lprServer"::Text) getLprServerArg
|
||||
|
||||
1
start.sh
1
start.sh
@ -22,6 +22,7 @@ export ALLOW_DEPRECATED=${ALLOW_DEPRECATED:-true}
|
||||
export ENCRYPT_ERRORS=${ENCRYPT_ERRORS:-false}
|
||||
export RIBBON=${RIBBON:-${__HOST:-localhost}}
|
||||
export APPROOT=${APPROOT:-http://localhost:$((${PORT_OFFSET:-0} + 3000))}
|
||||
export AVSPASS=${AVSPASS:-nopasswordset}
|
||||
unset HOST
|
||||
|
||||
move-back() {
|
||||
|
||||
@ -6,7 +6,7 @@ en-subject: Renewal of apron driving License
|
||||
author: Fraport AG - Fahrerausbildung (AVN-AR)
|
||||
phone: +49 69 690-30306
|
||||
email: fahrerausbildung@fraport.de
|
||||
url: <http://www.fraport.de/fahrerausbildung>
|
||||
url: <http://drive.fraport.de>
|
||||
place: Frankfurt/Main
|
||||
return-address:
|
||||
- 60547 Frankfurt
|
||||
@ -23,6 +23,7 @@ hyperrefoptions: hidelinks
|
||||
|
||||
### Metadaten, welche automatisch ersetzt werden:
|
||||
date: 11.11.1111
|
||||
expiry: 00.00.0000
|
||||
lang: de-de
|
||||
is-de: true
|
||||
login: 123456
|
||||
@ -51,9 +52,12 @@ $endfor$
|
||||
$if(is-de)$
|
||||
|
||||
<!-- deutsche Version des Briefes -->
|
||||
die Gültigkeit Ihres Vorfeldführerscheines läuft demnächst ab.
|
||||
Durch die erfolgreiche Teilnahme an einem E-Lernen können Sie
|
||||
die Gültigkeit um 2 Jahre verlängern. Verwenden Sie dazu die
|
||||
die Gültigkeit Ihres Vorfeldführerscheines läuft demnächst ab, am $expiry$.
|
||||
Durch die erfolgreiche Teilnahme an einem E-Lernen können Sie die Gültigkeit
|
||||
$if(validduration)$
|
||||
um $validduration$ Monate
|
||||
$endif$
|
||||
verlängern. Verwenden Sie dazu die
|
||||
Login-Daten aus dem geschützen Sichtfenster weiter unten.
|
||||
|
||||
Prüfling
|
||||
@ -75,8 +79,12 @@ $else$
|
||||
|
||||
<!-- englische Version des Briefes -->
|
||||
|
||||
your apron diving licence is about to expire soon.
|
||||
You may renew your apron driving licence by two years through successfully
|
||||
your apron diving licence is about to expire soon, on $expiry$.
|
||||
You may renew your apron driving licence
|
||||
$if(validduration)$
|
||||
by $validduration$ month
|
||||
$endif$
|
||||
through successfully
|
||||
completing an e-learning course. Please use the login data from the protected area below.
|
||||
|
||||
Examinee
|
||||
|
||||
@ -14,17 +14,21 @@ $newline never
|
||||
_{SomeMessage $ MsgMailSubjectQualificationExpiry qname}
|
||||
|
||||
<p>
|
||||
_{SomeMessage MsgMailAllocationNewCourseTip}
|
||||
<br />
|
||||
<a href=@{QualificationR qualificationSchool qualificationShorthand}>
|
||||
#{qualificationName}
|
||||
|
||||
#{nameHtml userDisplayName userSurname}
|
||||
#{show qualificationUserValidUntil}
|
||||
#{show qualificationUserFirstHeld}
|
||||
_{SomeMessage MsgMailBodyQualificationExpiry}
|
||||
|
||||
<p>
|
||||
<h3>
|
||||
EXPIRY
|
||||
TODO: Diese Nachricht muss noch überarbeitet werden.
|
||||
<dl>
|
||||
<dt>_{SomeMessage MsgQualificationName}
|
||||
<dd>
|
||||
<a href=@{QualificationR qualificationSchool qualificationShorthand}>
|
||||
#{qualificationName}
|
||||
<dt>_{SomeMessage MsgLmsUser}
|
||||
<dd>#{nameHtml userDisplayName userSurname}
|
||||
<dt>_{SomeMessage MsgLmsQualificationValidUntil}
|
||||
<dd>#{expiryDate}
|
||||
|
||||
<p>
|
||||
_{SomeMessage MsgLmsNoRenewal}
|
||||
|
||||
|
||||
^{ihamletSomeMessage editNotifications}
|
||||
|
||||
@ -14,28 +14,21 @@ $newline never
|
||||
_{SomeMessage $ MsgMailSubjectQualificationRenewal qname}
|
||||
|
||||
<p>
|
||||
_{SomeMessage MsgMailLmsRenewalBody}
|
||||
<br />
|
||||
<a href=@{QualificationR qualificationSchool qualificationShorthand}>
|
||||
#{qualificationName}
|
||||
|
||||
<p>
|
||||
Name:
|
||||
#{nameHtml userDisplayName userSurname}
|
||||
_{SomeMessage MsgMailBodyQualificationRenewal}
|
||||
|
||||
<p>
|
||||
Qualifikation:
|
||||
#{qname}
|
||||
|
||||
<p>
|
||||
Gültig bis:
|
||||
#{show qualificationUserValidUntil}
|
||||
<p>
|
||||
Zuerst erhalten:
|
||||
#{show qualificationUserFirstHeld}
|
||||
<dl>
|
||||
<dt>_{SomeMessage MsgQualificationName}
|
||||
<dd>
|
||||
<a href=@{QualificationR qualificationSchool qualificationShorthand}>
|
||||
#{qualificationName}
|
||||
<dt>_{SomeMessage MsgLmsUser}
|
||||
<dd>#{nameHtml userDisplayName userSurname}
|
||||
<dt>_{SomeMessage MsgLmsQualificationValidUntil}
|
||||
<dd>#{expiryDate}
|
||||
|
||||
<p>
|
||||
<h3>
|
||||
RENEWAL
|
||||
TODO: Diese Nachricht muss noch überarbeitet werden.
|
||||
_{SomeMessage MsgLmsRenewalInstructions}
|
||||
|
||||
|
||||
^{ihamletSomeMessage editNotifications}
|
||||
|
||||
@ -18,6 +18,15 @@ $newline never
|
||||
_{MsgTableMatrikelNr}
|
||||
<dd .deflist__dd>
|
||||
#{matnr}
|
||||
$maybe addr <- userPostAddress
|
||||
<dt .deflist__dt>
|
||||
_{MsgAdminUserPostAddress}
|
||||
<dd .deflist__dd>
|
||||
#{addr}
|
||||
<dt .deflist__dt>
|
||||
_{MsgAdminUserPrefersPostal}
|
||||
<dd .deflist__dd>
|
||||
#{show userPrefersPostal}
|
||||
<dt .deflist__dt>
|
||||
_{MsgTableEmail}
|
||||
<dd .deflist__dd>
|
||||
@ -27,6 +36,13 @@ $newline never
|
||||
_{MsgUserDisplayEmail}
|
||||
<dd .deflist__dd .email>
|
||||
#{userDisplayEmail}
|
||||
<dt .deflist__dt>
|
||||
_{MsgAdminUserPinPassword}
|
||||
<dd .deflist__dd>
|
||||
$maybe _pass <- userPinPassword
|
||||
OK
|
||||
$nothing
|
||||
NO
|
||||
$maybe telephonenr <- userTelephone
|
||||
<dt .deflist__dt>
|
||||
_{MsgUserTelephone}
|
||||
|
||||
@ -111,6 +111,9 @@ fillDb = do
|
||||
, userMobile = Nothing
|
||||
, userCompanyPersonalNumber = Nothing
|
||||
, userCompanyDepartment = Nothing
|
||||
, userPinPassword = Nothing
|
||||
, userPostAddress = Nothing
|
||||
, userPrefersPostal = False
|
||||
, userExamOfficeGetSynced = userDefaultExamOfficeGetSynced
|
||||
, userExamOfficeGetLabels = userDefaultExamOfficeGetLabels
|
||||
}
|
||||
@ -146,6 +149,9 @@ fillDb = do
|
||||
, userTelephone = Nothing
|
||||
, userCompanyPersonalNumber = Nothing
|
||||
, userCompanyDepartment = Nothing
|
||||
, userPinPassword = Nothing
|
||||
, userPostAddress = Nothing
|
||||
, userPrefersPostal = False
|
||||
, userExamOfficeGetSynced = userDefaultExamOfficeGetSynced
|
||||
, userExamOfficeGetLabels = userDefaultExamOfficeGetLabels
|
||||
}
|
||||
@ -187,6 +193,9 @@ fillDb = do
|
||||
, userMobile = Just "0173 69 99 646"
|
||||
, userCompanyPersonalNumber = Just "57138"
|
||||
, userCompanyDepartment = Just "AVN-AR2"
|
||||
, userPinPassword = Nothing
|
||||
, userPostAddress = Nothing
|
||||
, userPrefersPostal = False
|
||||
, userExamOfficeGetSynced = userDefaultExamOfficeGetSynced
|
||||
, userExamOfficeGetLabels = userDefaultExamOfficeGetLabels
|
||||
}
|
||||
@ -222,6 +231,9 @@ fillDb = do
|
||||
, userMobile = Nothing
|
||||
, userCompanyPersonalNumber = Nothing
|
||||
, userCompanyDepartment = Nothing
|
||||
, userPinPassword = Nothing
|
||||
, userPostAddress = Nothing
|
||||
, userPrefersPostal = False
|
||||
, userExamOfficeGetSynced = userDefaultExamOfficeGetSynced
|
||||
, userExamOfficeGetLabels = userDefaultExamOfficeGetLabels
|
||||
}
|
||||
@ -257,6 +269,9 @@ fillDb = do
|
||||
, userMobile = Nothing
|
||||
, userCompanyPersonalNumber = Nothing
|
||||
, userCompanyDepartment = Nothing
|
||||
, userPinPassword = Nothing
|
||||
, userPostAddress = Nothing
|
||||
, userPrefersPostal = False
|
||||
, userExamOfficeGetSynced = userDefaultExamOfficeGetSynced
|
||||
, userExamOfficeGetLabels = userDefaultExamOfficeGetLabels
|
||||
}
|
||||
@ -292,6 +307,9 @@ fillDb = do
|
||||
, userMobile = Nothing
|
||||
, userCompanyPersonalNumber = Nothing
|
||||
, userCompanyDepartment = Nothing
|
||||
, userPinPassword = Nothing
|
||||
, userPostAddress = Nothing
|
||||
, userPrefersPostal = False
|
||||
, userExamOfficeGetSynced = userDefaultExamOfficeGetSynced
|
||||
, userExamOfficeGetLabels = userDefaultExamOfficeGetLabels
|
||||
}
|
||||
@ -327,6 +345,9 @@ fillDb = do
|
||||
, userMobile = Nothing
|
||||
, userCompanyPersonalNumber = Nothing
|
||||
, userCompanyDepartment = Nothing
|
||||
, userPinPassword = Nothing
|
||||
, userPostAddress = Nothing
|
||||
, userPrefersPostal = False
|
||||
, userExamOfficeGetSynced = False
|
||||
, userExamOfficeGetLabels = True
|
||||
}
|
||||
@ -392,6 +413,9 @@ fillDb = do
|
||||
, userMobile = Nothing
|
||||
, userCompanyPersonalNumber = Nothing
|
||||
, userCompanyDepartment = Nothing
|
||||
, userPinPassword = Nothing
|
||||
, userPostAddress = Nothing
|
||||
, userPrefersPostal = False
|
||||
, userExamOfficeGetSynced = userDefaultExamOfficeGetSynced
|
||||
, userExamOfficeGetLabels = userDefaultExamOfficeGetLabels
|
||||
}
|
||||
|
||||
@ -1,4 +1,5 @@
|
||||
{-# OPTIONS_GHC -Wno-redundant-constraints #-}
|
||||
{-# OPTIONS -Wno-unused-top-binds #-}
|
||||
|
||||
module Handler.Utils.ExamSpec (spec) where
|
||||
|
||||
@ -21,6 +22,10 @@ import qualified Data.RFC5051 as RFC5051
|
||||
import Handler.Utils.Exam
|
||||
|
||||
|
||||
spec :: Spec
|
||||
-- spec = test_spec
|
||||
spec = return () -- TODO: tests deactivated since exams are currently not used
|
||||
|
||||
-- direct copy&paste from an (currently) unmerged pull request for hspec-expectations
|
||||
-- https://github.com/hspec/hspec-expectations/blob/6b4a475e42b0d44008c150727dea25dd79f568f2/src/Test/Hspec/Expectations.hs
|
||||
-- |
|
||||
@ -91,8 +96,8 @@ instance Show UserProperties where
|
||||
++ ", userMatrikelnummer=" ++ show userMatrikelnummer ++ "}"
|
||||
|
||||
-- function Handler.Utils.examAutoOccurrence
|
||||
spec :: Spec
|
||||
spec = do
|
||||
test_spec :: Spec
|
||||
test_spec = do
|
||||
describe "examAutoOccurrence" $ do
|
||||
describe "Surname" $ testWithRule ExamRoomSurname
|
||||
describe "Matriculation" $ testWithRule ExamRoomMatriculation
|
||||
|
||||
@ -363,7 +363,7 @@ instance Arbitrary SemVer.Version where
|
||||
<*> fmap getNonNegative arbitrary
|
||||
<*> fmap getNonNegative arbitrary
|
||||
<*> arbitrary
|
||||
<*> arbitrary
|
||||
<*> pure mempty -- Ord SemVer.Version ignores Metadata, so the Ord properties don't hold
|
||||
|
||||
instance Arbitrary SemVer.Identifier where
|
||||
arbitrary = -- oneof
|
||||
|
||||
@ -130,8 +130,11 @@ instance Arbitrary User where
|
||||
userShowSex <- arbitrary
|
||||
userMobile <- fmap pack . assertM' (not . null) <$> listOf (elements $ [' ', '+', '-', '/', '_'] ++ ['0'..'9'])
|
||||
userTelephone <- fmap pack . assertM' (not . null) <$> listOf (elements $ [' ', '+', '-', '/', '_'] ++ ['0'..'9'])
|
||||
userCompanyPersonalNumber <- fmap pack . assertM' (not . null) <$> listOf (elements ['0'..'9'])
|
||||
userCompanyPersonalNumber <- fmap pack . assertM' (not . null) <$> listOf (elements ['0'..'9'])
|
||||
userCompanyDepartment <- arbitrary
|
||||
userPinPassword <- arbitrary
|
||||
userPostAddress <- arbitrary -- TODO: not a good address
|
||||
userPrefersPostal <- arbitrary
|
||||
userExamOfficeGetSynced <- arbitrary
|
||||
userExamOfficeGetLabels <- arbitrary
|
||||
|
||||
|
||||
@ -23,13 +23,13 @@ instance Arbitrary ArbitraryMeta where
|
||||
(x2 :: [Inlines]) <- filter (not . Fold.null) <$> arbitrary
|
||||
(x3 :: Inlines) <- arbitrary
|
||||
(x4 :: [(Text, Text)]) <- filter (not . T.null . fst) <$> arbitrary
|
||||
(x5 :: [(Text, Bool)]) <- filter (not . T.null . fst) <$> arbitrary
|
||||
(x5 :: [(Text, Bool)]) <- filter (not . T.null . fst) <$> arbitrary
|
||||
return $ ArbitraryMeta
|
||||
$ setMeta "title" x1
|
||||
$ setMeta "author" x2
|
||||
$ setMeta "date" x3
|
||||
$ applyMetas x4
|
||||
$ applyMetas x5
|
||||
$ applyMetas (fmap (second Just) x4)
|
||||
$ applyMetas (fmap (second Just) x5)
|
||||
nullMeta
|
||||
|
||||
|
||||
@ -43,16 +43,28 @@ instance Arbitrary ArbitraryMeta where
|
||||
|
||||
spec :: Spec
|
||||
spec = do
|
||||
let mlist = Map.toList . unMeta
|
||||
let mlist = Map.toAscList . unMeta
|
||||
|
||||
describe "applyMetas" $ do
|
||||
it "should actually set values" $ do
|
||||
(ml, pd) <- generate arbitrary
|
||||
let
|
||||
(ml, abMetaOriginal, blocks) <- generate arbitrary
|
||||
let
|
||||
metaOriginal = unArbitraryMeta abMetaOriginal
|
||||
pd = Pandoc metaOriginal blocks
|
||||
mlKeys = Set.fromList $ fst <$> ml
|
||||
(Pandoc newMeta _) = applyMetas (fmap MetaString <$> ml) pd
|
||||
(Pandoc newMeta _) = applyMetas (fmap (Just . MetaString) <$> ml) pd
|
||||
ml' = [(k,t) | (k, MetaString t) <- mlist newMeta, Set.member k mlKeys]
|
||||
ml `shouldMatchList` ml'
|
||||
it "should preserve untouched settings" $ do
|
||||
(ml, abMetaOriginal, blocks) <- generate arbitrary
|
||||
let
|
||||
metaOriginal = unArbitraryMeta abMetaOriginal
|
||||
pd = Pandoc metaOriginal blocks
|
||||
nullKeys = Set.fromList [k | (k, Nothing) <- ml]
|
||||
(Pandoc newMeta _) = applyMetas (fmap (fmap MetaString) <$> ml) pd
|
||||
oldm = [(k,t) | (k, t) <- mlist metaOriginal , Set.member k nullKeys]
|
||||
newm = [(k,t) | (k, t) <- mlist newMeta , Set.member k nullKeys]
|
||||
oldm `shouldMatchList` newm
|
||||
|
||||
describe "addMeta" $ do
|
||||
it "should possibly overwrite existing settings" $ do
|
||||
|
||||
@ -49,3 +49,6 @@ fakeUser adjUser = adjUser User{..}
|
||||
userTelephone = Nothing
|
||||
userCompanyPersonalNumber = Nothing
|
||||
userCompanyDepartment = Nothing
|
||||
userPinPassword = Nothing
|
||||
userPostAddress = Nothing
|
||||
userPrefersPostal = False
|
||||
|
||||
@ -2,10 +2,8 @@ module Utils.TypesSpec where
|
||||
|
||||
import TestImport
|
||||
|
||||
import Utils.Avs
|
||||
|
||||
|
||||
instance Arbitrary AvsDataCardColor where
|
||||
instance Arbitrary AvsDataCardColor where
|
||||
arbitrary = genericArbitrary
|
||||
shrink = genericShrink
|
||||
|
||||
@ -41,6 +39,8 @@ instance Arbitrary AvsQueryPerson where
|
||||
spec :: Spec
|
||||
spec = do
|
||||
parallel $ do
|
||||
lawsCheckHspec (Proxy @AvsDataPersonCard)
|
||||
[ eqLaws, ordLaws, showLaws, showReadLaws, jsonLaws ]
|
||||
lawsCheckHspec (Proxy @AvsResponsePerson)
|
||||
[ eqLaws, showLaws, showReadLaws, jsonLaws]
|
||||
lawsCheckHspec (Proxy @AvsResponseStatus)
|
||||
@ -49,3 +49,23 @@ spec = do
|
||||
[ eqLaws, showLaws, showReadLaws, jsonLaws]
|
||||
lawsCheckHspec (Proxy @AvsQueryStatus)
|
||||
[ eqLaws, showLaws, showReadLaws, jsonLaws]
|
||||
|
||||
describe "Ord AvsDataCard" $ do
|
||||
it "prioritises avsDataValid" . property $
|
||||
\p0 p1@AvsDataPersonCard{avsDataValid=v1} ->
|
||||
let p2@AvsDataPersonCard{avsDataValid=v2} = p0 in
|
||||
(v1 /= v2) ==> compare p1 p2 == compare v1 v2
|
||||
it "prioritises avsDataValidTo after avsDataValid" . property $
|
||||
\p0 p1@AvsDataPersonCard{avsDataValid=v1, avsDataValidTo=t1} ->
|
||||
let p2@AvsDataPersonCard{avsDataValidTo=t2} = p0{avsDataValid=v1} in
|
||||
(t1 /= t2) ==> compare p1 p2 == compare t1 t2
|
||||
it "prioritises avsDataIssueDate after avsDataValid and avsDataValidTo" . property $
|
||||
\p0 p1@AvsDataPersonCard{avsDataValid=v1, avsDataValidTo=t1, avsDataIssueDate=d1} ->
|
||||
let p2@AvsDataPersonCard{avsDataIssueDate=d2} = p0{avsDataValid=v1, avsDataValidTo=t1} in
|
||||
(d1 /= d2) ==> compare p1 p2 == compare d1 d2
|
||||
{- naive implementations discards too many tests in order to produce a meaningful result:
|
||||
it "prioritises avsDataIssueDate after avsDataValid and avsDataValidTo" . property $
|
||||
\p1@AvsDataPersonCard{avsDataValid=v1, avsDataValidTo=t1, avsDataIssueDate=d1}
|
||||
p2@AvsDataPersonCard{avsDataValid=v2, avsDataValidTo=t2, avsDataIssueDate=d2} ->
|
||||
(v1 == v2 && t1 == t2 && d1 /= d2) ==> compare p1 p2 == compare d1 d2
|
||||
-}
|
||||
|
||||
Loading…
Reference in New Issue
Block a user