Merge branch 'fradrive/letter'

This commit is contained in:
Steffen Jost 2022-09-02 18:55:10 +02:00
commit d4ea9e8088
55 changed files with 925 additions and 469 deletions

1
db.sh
View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

@ -75,6 +75,7 @@ data AuthTag -- sortiert nach gewünschter Reihenfolge auf /authpreds, d.h. Prä
| AuthTutorControl
| AuthExamOffice
| AuthSystemExamOffice
| AuthSystemPrinter
| AuthEvaluation
| AuthAllocationAdmin
| AuthAllocationRegistered

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

@ -49,3 +49,6 @@ fakeUser adjUser = adjUser User{..}
userTelephone = Nothing
userCompanyPersonalNumber = Nothing
userCompanyDepartment = Nothing
userPinPassword = Nothing
userPostAddress = Nothing
userPrefersPostal = False

View File

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