diff --git a/db.sh b/db.sh index a585ee1f6..7c154686d 100755 --- a/db.sh +++ b/db.sh @@ -13,4 +13,5 @@ fi stack build --fast --flag uniworx:-library-only --flag uniworx:dev export SERVER_SESSION_ACID_FALLBACK=${SERVER_SESSION_ACID_FALLBACK:-true} +export AVSPASS=${AVSPASS:-nopasswordset} stack exec uniworxdb -- $@ diff --git a/messages/uniworx/categories/authorization/de-de-formal.msg b/messages/uniworx/categories/authorization/de-de-formal.msg index 19764c991..fab2eb322 100644 --- a/messages/uniworx/categories/authorization/de-de-formal.msg +++ b/messages/uniworx/categories/authorization/de-de-formal.msg @@ -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. diff --git a/messages/uniworx/categories/authorization/en-eu.msg b/messages/uniworx/categories/authorization/en-eu.msg index f2a64dbe9..f5e82dd4c 100644 --- a/messages/uniworx/categories/authorization/en-eu.msg +++ b/messages/uniworx/categories/authorization/en-eu.msg @@ -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. diff --git a/messages/uniworx/categories/model_types/de-de-formal.msg b/messages/uniworx/categories/model_types/de-de-formal.msg index a3fd04ca8..fb611d0ab 100644 --- a/messages/uniworx/categories/model_types/de-de-formal.msg +++ b/messages/uniworx/categories/model_types/de-de-formal.msg @@ -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 diff --git a/messages/uniworx/categories/model_types/en-eu.msg b/messages/uniworx/categories/model_types/en-eu.msg index 2bbb34a44..dd0ec7f95 100644 --- a/messages/uniworx/categories/model_types/en-eu.msg +++ b/messages/uniworx/categories/model_types/en-eu.msg @@ -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 \ No newline at end of file diff --git a/messages/uniworx/categories/qualification/de-de-formal.msg b/messages/uniworx/categories/qualification/de-de-formal.msg index 7fdeea11f..bf0630997 100644 --- a/messages/uniworx/categories/qualification/de-de-formal.msg +++ b/messages/uniworx/categories/qualification/de-de-formal.msg @@ -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 diff --git a/messages/uniworx/categories/qualification/en-eu.msg b/messages/uniworx/categories/qualification/en-eu.msg index 546f2d9d0..9ac082788 100644 --- a/messages/uniworx/categories/qualification/en-eu.msg +++ b/messages/uniworx/categories/qualification/en-eu.msg @@ -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 diff --git a/messages/uniworx/categories/settings/auth_settings/de-de-formal.msg b/messages/uniworx/categories/settings/auth_settings/de-de-formal.msg index 8f9acaa70..95f1a6d85 100644 --- a/messages/uniworx/categories/settings/auth_settings/de-de-formal.msg +++ b/messages/uniworx/categories/settings/auth_settings/de-de-formal.msg @@ -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 diff --git a/messages/uniworx/categories/settings/auth_settings/en-eu.msg b/messages/uniworx/categories/settings/auth_settings/en-eu.msg index 1109b0c27..98dcfe1ac 100644 --- a/messages/uniworx/categories/settings/auth_settings/en-eu.msg +++ b/messages/uniworx/categories/settings/auth_settings/en-eu.msg @@ -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 diff --git a/messages/uniworx/categories/user/de-de-formal.msg b/messages/uniworx/categories/user/de-de-formal.msg index 0a7682d01..e7a9e1669 100644 --- a/messages/uniworx/categories/user/de-de-formal.msg +++ b/messages/uniworx/categories/user/de-de-formal.msg @@ -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 diff --git a/messages/uniworx/categories/user/en-eu.msg b/messages/uniworx/categories/user/en-eu.msg index 8e1a5c7bc..b918f5bde 100644 --- a/messages/uniworx/categories/user/en-eu.msg +++ b/messages/uniworx/categories/user/en-eu.msg @@ -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 diff --git a/messages/uniworx/utils/navigation/menu/de-de-formal.msg b/messages/uniworx/utils/navigation/menu/de-de-formal.msg index 83fa124e1..1c8948184 100644 --- a/messages/uniworx/utils/navigation/menu/de-de-formal.msg +++ b/messages/uniworx/utils/navigation/menu/de-de-formal.msg @@ -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 diff --git a/messages/uniworx/utils/navigation/menu/en-eu.msg b/messages/uniworx/utils/navigation/menu/en-eu.msg index 1570ce735..b0e1779d1 100644 --- a/messages/uniworx/utils/navigation/menu/en-eu.msg +++ b/messages/uniworx/utils/navigation/menu/en-eu.msg @@ -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 diff --git a/models/lms.model b/models/lms.model index 8486ccc5a..986ee5d27 100644 --- a/models/lms.model +++ b/models/lms.model @@ -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! diff --git a/models/users.model b/models/users.model index a3f4ba1bd..7bc14297a 100644 --- a/models/users.model +++ b/models/users.model @@ -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 diff --git a/routes b/routes index 98a440272..2e68773a5 100644 --- a/routes +++ b/routes @@ -9,6 +9,8 @@ -- -- Admins always have access to entities within their assigned schools. -- +-- Access tags are defined in Model.Types.Security +-- -- Access Tags: -- !free -- free for all -- !lecturer -- lecturer for this course (or for any school, if route is not connected to a course) @@ -61,9 +63,9 @@ /admin/crontab AdminCrontabR GET /admin/avs AdminAvsR GET POST -/print PrintCenterR GET POST +/print PrintCenterR GET POST !system-printer /print/send PrintSendR GET POST -/print/download/#CryptoUUIDPrintJob PrintDownloadR GET +/print/download/#CryptoUUIDPrintJob PrintDownloadR GET !system-printer /health HealthR GET !free /instance InstanceR GET !free @@ -263,7 +265,7 @@ -- for users /qualification QualificationAllR GET !free /qualification/#SchoolId QualificationSchoolR GET !free -- TODO -/qualification/#SchoolId/#QualificationShorthand QualificationR GET !free -- must be logged in though +/qualification/#SchoolId/#QualificationShorthand QualificationR GET -- TODO make !free again after repurpose -- OSIS CSV Export Demo /lms LmsAllR GET POST /lms/#SchoolId LmsSchoolR GET @@ -277,6 +279,7 @@ /lms/#SchoolId/#QualificationShorthand/result LmsResultR GET POST /lms/#SchoolId/#QualificationShorthand/result/upload LmsResultUploadR GET POST /lms/#SchoolId/#QualificationShorthand/result/direct LmsResultDirectR POST +/lms/#SchoolId/#QualificationShorthand/fake LmsFakeR GET POST -- TODO: delete this testing URL /api ApiDocsR GET !free /swagger SwaggerR GET !free diff --git a/src/Application.hs b/src/Application.hs index d3df9d441..2b5e6564c 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -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 diff --git a/src/Auth/LDAP.hs b/src/Auth/LDAP.hs index 75b8acfdb..e96b1a90d 100644 --- a/src/Auth/LDAP.hs +++ b/src/Auth/LDAP.hs @@ -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" diff --git a/src/Foundation/Authorization.hs b/src/Foundation/Authorization.hs index 6df5f3417..f77635ce8 100644 --- a/src/Foundation/Authorization.hs +++ b/src/Foundation/Authorization.hs @@ -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 diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index f63c1093f..419c3de01 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -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 diff --git a/src/Foundation/Yesod/Auth.hs b/src/Foundation/Yesod/Auth.hs index 00d8227a0..785acc5d1 100644 --- a/src/Foundation/Yesod/Auth.hs +++ b/src/Foundation/Yesod/Auth.hs @@ -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 diff --git a/src/Handler/Course/Edit.hs b/src/Handler/Course/Edit.hs index a43db9ec1..b29115833 100644 --- a/src/Handler/Course/Edit.hs +++ b/src/Handler/Course/Edit.hs @@ -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 diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index 8deee987b..292388fca 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -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) diff --git a/src/Handler/LMS/Fake.hs b/src/Handler/LMS/Fake.hs new file mode 100644 index 000000000..eabd8a656 --- /dev/null +++ b/src/Handler/LMS/Fake.hs @@ -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} + +

Hinweise: +