Merge branch 'fradrive/letter'

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

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.

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.

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

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

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
+MailSubjectQualificationRenewal qname@Text: Qualifikation #{qname} muss demnächst erneuert werden
-MailSubjectQualificationExpiry qname@Text: Ihre Qualifikation #{qname} läuft demnächst ab
+MailSubjectQualificationExpiry qname@Text: Qualifikation #{qname} läuft demnächst ab
-MailLmsRenewalBody: Sie müssen diese Qualifikaton demnächst durch einen E-Lernen Kurs erneuern.
+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

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
+MailSubjectQualificationRenewal qname@Text: Qualification #{qname} must be renewed shortly
-MailSubjectQualificationExpiry qname@Text: Your qualification #{qname} expires soon
+MailSubjectQualificationExpiry qname@Text: Qualification #{qname} expires soon
-MailLmsRenewalBody: You will soon need to renew this qualficiation by completing an e-learning course.
+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

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

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

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

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

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

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

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!

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
+    pinPassword           Text Maybe -- used to encrypt pins within emails
-    examOfficeGetLabels Bool default=true   -- whether labels should be displayed for exam results by default
+    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
+    function SystemFunction   -- Defined in Model.Types.User
-    manual   Bool
+    manual   Bool             -- Inserted manually by Admin or automatic from LDAP
-    isOptOut Bool
+    isOptOut Bool             -- User has currently deactivate the role for themselves
     UniqueUserSystemFunction user function
     deriving Generic
 UserExamOffice

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

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."
+          -- $logErrorS "avsPrepare" "appAvsConfig is empty, i.e. invalid AVS configuration settings."
-          return Nothing
+          -- return Nothing
-          -- liftIO exitFailure
+          error "AvsConfig is empty, i.e. invalid AVS configuration settings."          
-        Just avsConf -> do
+          
-          -- TODO: consider using Servant.Client.Core.BaseUrl.Instances.parseBaseUrl' within Settings already at Startup!
+        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

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"

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

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

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    
+  let
-    userEmail'          = fold $ do
+    ldapMap :: Map.Map Ldap.Attr [Ldap.AttrValue] -- Recall: Ldap.AttrValue == ByteString
-      k' <- toList ldapUserEmail
+    ldapMap = Map.fromListWith (++) $ ldapData <&> second (filter (not . ByteString.null))
-      (k, v) <- ldapData
+
-      guard $ k' == k
+    -- only accept a single result, throw error otherwise
-      return v
+    -- decodeLdap1 :: (MonadThrow m, Exception e) => Ldap.Attr -> e -> m Text
-    -- SJ says: this highly repetitive code needs fefactoring; why not turn ldapData into a Data.Map right away instead of repetitive list iteration?
+    decodeLdap1 attr err 
-    userLdapPrimaryKey' = fold [ v | (k, v) <- ldapData, k == ldapPrimaryKey        ]    
+      | [bs] <- ldapMap !!! attr 
-    userIdent''         = fold [ v | (k, v) <- ldapData, k == ldapUserPrincipalName ]    
+      , Right t <- Text.decodeUtf8' bs
-    userDisplayName''   = fold [ v | (k, v) <- ldapData, k == ldapUserDisplayName   ]
+        = return t
-    userFirstName'      = fold [ v | (k, v) <- ldapData, k == ldapUserFirstName     ]
+      | otherwise = throwM err
-    userSurname'        = fold [ v | (k, v) <- ldapData, k == ldapUserSurname       ]
+    
-    userTelephone'      = fold [ v | (k, v) <- ldapData, k == ldapUserTelephone     ]
+    -- accept any successful decoding or empty; only throw an error if all decodings fail
-    userMobile'         = fold [ v | (k, v) <- ldapData, k == ldapUserMobile        ]
+    -- decodeLdap' :: (Exception e) => Ldap.Attr -> e -> m Text
-    userFraportPersonalnummer' = fold [ v | (k, v) <- ldapData, k == ldapUserFraportPersonalnummer ]
+    decodeLdap' attr err
-    userFraportAbteilung'      = fold [ v | (k, v) <- ldapData, k == ldapUserFraportAbteilung      ]
+        | []    <-        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
+  userFirstName <- decodeLdap1 ldapUserFirstName CampusUserInvalidGivenName
-    | [bs] <- userDisplayName''
+  userSurname   <- decodeLdap1 ldapUserSurname   CampusUserInvalidSurname
-    , Right userDisplayName' <- Text.decodeUtf8' bs
+  userTitle     <- decodeLdap' ldapUserTitle     CampusUserInvalidTitle
-      -> return userDisplayName'
+
-    | otherwise
+  userDisplayName' <- decodeLdap1 ldapUserDisplayName CampusUserInvalidDisplayName >>= 
-      -> throwM CampusUserInvalidDisplayName
+    (maybeThrow CampusUserInvalidDisplayName . checkDisplayName userTitle userFirstName userSurname)
-  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
 
   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
+      { userMaxFavourites           = userDefaultMaxFavourites
-      , userMaxFavouriteTerms    = userDefaultMaxFavouriteTerms
+      , userMaxFavouriteTerms       = userDefaultMaxFavouriteTerms
-      , userTheme                = userDefaultTheme
+      , userTheme                   = userDefaultTheme
-      , userDateTimeFormat       = userDefaultDateTimeFormat
+      , userDateTimeFormat          = userDefaultDateTimeFormat
-      , userDateFormat           = userDefaultDateFormat
+      , userDateFormat              = userDefaultDateFormat
-      , userTimeFormat           = userDefaultTimeFormat
+      , userTimeFormat              = userDefaultTimeFormat
-      , userDownloadFiles        = userDefaultDownloadFiles
+      , userDownloadFiles           = userDefaultDownloadFiles
-      , userWarningDays          = userDefaultWarningDays
+      , userWarningDays             = userDefaultWarningDays
-      , userShowSex              = userDefaultShowSex
+      , userShowSex                 = userDefaultShowSex
-      , userSex                  = Nothing
+      , userSex                     = Nothing
-      , userExamOfficeGetSynced  = userDefaultExamOfficeGetSynced
+      , userExamOfficeGetSynced     = userDefaultExamOfficeGetSynced
-      , userExamOfficeGetLabels  = userDefaultExamOfficeGetLabels
+      , userExamOfficeGetLabels     = userDefaultExamOfficeGetLabels
-      , userNotificationSettings = def
+      , userNotificationSettings    = def
-      , userLanguages            = Nothing
+      , userLanguages               = Nothing
-      , userCsvOptions           = def
+      , userCsvOptions              = def
-      , userTokensIssuedAfter    = Nothing
+      , userTokensIssuedAfter       = Nothing
-      , userCreated              = now
+      , userCreated                 = now
-      , userLastLdapSynchronisation = Just now
+      , userLastLdapSynchronisation = Just now      
-      , userDisplayName          = userDisplayName'
+      , userDisplayName             = userDisplayName'
-      , userDisplayEmail         = userEmail
+      , userDisplayEmail            = userEmail
-      , userMatrikelnummer       = Nothing -- not known from LDAP, must be derived from REST interface to AVS TODO
+      , userMatrikelnummer          = Nothing -- not known from LDAP, must be derived from REST interface to AVS TODO      
-      , userTitle                = Nothing
+      , 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 =  [ 
+    userUpdate =  [
-                  -- UserDisplayName             =. userDisplayName -- never updated, since users are allowed to change their DisplayName
+                  -- UserDisplayName             =. userDisplayName -- not updated here, since users are allowed to change their DisplayName; see line 272
                     UserFirstName               =. userFirstName
-                  , UserSurname                 =. userSurname                  
+                  , UserSurname                 =. userSurname
-                  , UserEmail                   =. userEmail                  
+                  , 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

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

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)
 

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}
+
+        <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)

src/Handler/PrintCenter.hs

@@ -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      as T
-import qualified Data.Text.Lazy as LT
+-- 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"
+    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
 
 mprToMetaUser :: (MonadHandler m, HandlerSite m ~ UniWorX) => Entity User -> MetaPinRenewal -> m P.Meta
 mprToMetaUser entUser@Entity{entityVal = u} mpr = do 

src/Handler/Qualification.hs

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

src/Handler/Users/Add.hs

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

src/Handler/Utils/LdapSystemFunctions.hs

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

src/Handler/Utils/Profile.hs

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

src/Handler/Utils/Users.hs

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

src/Jobs/Handler/LMS.hs

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

src/Jobs/Handler/SendNotification/Qualification.hs

@@ -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
+-- NOTE: qualificationRenewal expects that LmsUser already exists for recipient
-checkEmailOk = const True -- TODO
-
-
 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)
+    <*> getJustBy (UniqueQualificationUser    nQualification jRecipient)
-  let qname = CI.original qualificationName
+    <*> getJustBy (UniqueLmsQualificationUser nQualification jRecipient)
-      -- content = $(i18nWidgetFile "qualification/renewal")
+  let entRecipient = Entity jRecipient recipient
+      qname = CI.original qualificationName
+
   $logDebugS "LMS" $ "Notify " <> tshow jRecipient <> " for renewal of qualification " <> qname
 
-  let pdfMeta = applyMetas 
+  now <- liftIO getCurrentTime
-                  [ ("recipient", userDisplayName)                  
+  letterDate <- formatTimeUser SelFormatDate now                         $ Just entRecipient
-                  -- TODO: add more info to interpolate here!
+  expiryDate <- formatTimeUser SelFormatDate qualificationUserValidUntil $ Just entRecipient
-                  ] mempty
+
+  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"
+    Right pdf | userPrefersLetter recipient -> do
-        setSubjectI $ MsgMailSubjectQualificationRenewal qname
+        let printJobName = "Renewal"
-
+            printSender  = Nothing 
-        editNotifications <- mkEditNotifications jRecipient -- TODO: add to hamlet file again
+        runDB (sendLetter printJobName pdf printSender (Just jRecipient) Nothing (Just nQualification)) >>= \case        
-        -- 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
           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")
+
+    

src/Model.hs

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

src/Model/Types.hs

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

src/Model/Types/Avs.hs

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

src/Model/Types/Languages.hs

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

src/Model/Types/Markup.hs

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

src/Model/Types/Security.hs

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

src/Model/Types/User.hs

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

src/Utils.hs

@@ -654,6 +654,11 @@ infixl 5 !!!
 (!!!) :: (Ord k, Monoid v) => Map k v -> k -> v
 (!!!) m k = fromMaybe mempty $ Map.lookup k m
 
+lookupSome :: (Monad m, Ord k, Monoid (m v)) => Map k (m v) -> m k -> m v
+-- lookupSome :: Ord k => Map k [v] -> [k] -> [v] 
+-- lookupSome m ks = ks >>= (m !!!)
+lookupSome = (=<<) . (!!!)
+
 groupMap :: (Ord k, Ord v) => [(k,v)] -> Map k (Set v)
 groupMap l = Map.fromListWith mappend [(k, Set.singleton v) | (k,v) <- l]
 
@@ -878,6 +883,7 @@ whenIsRight (Left  _) _ = pure ()
 throwLeft :: (MonadThrow m, Exception exc) => Either exc a -> m a
 throwLeft = either throwM return
 
+
 {- Just a reminder for Steffen:
 mapLeft :: (a -> c) -> Either a b -> Either c b 
 mapLeft = over _Left 
@@ -888,7 +894,7 @@ actLeft (Left  x) f = f x
 actLeft (Right y) _ = pure $ Right y
 
 -- | like monadic bind for 'Either', but wrapped in another monad
---   ok to use once, otherweise better to use 'Control.Monad.Trans.Except' instead
+--   ok to use once, otherwise better to use 'Control.Monad.Trans.Except' instead
 actRight :: Applicative f => Either a b -> (b -> f (Either a c)) -> f (Either a c)
 actRight (Left  x) _ = pure $ Left x
 actRight (Right y) f = f y
@@ -1578,6 +1584,15 @@ maxOn = maxBy . comparing
 inBetween:: Ord a => a -> (a,a) -> Bool
 inBetween x (lower,upper) = lower <= x && x <= upper
 
+-- | Given to values and a criterion, returns the unique argument that fulfills the criterion, if it exists
+pickBetter :: a -> a -> (a -> Bool) -> Maybe a
+pickBetter x y crit
+    | cx == cy  = Nothing
+    | cx        = Just x
+    | otherwise = Just y
+  where 
+    cx = crit x 
+    cy = crit y
 
 ------------
 -- Random --

src/Utils/Avs.hs

@@ -3,203 +3,11 @@ module Utils.Avs where
 import Import.NoModel hiding ((.=))
 import Utils.Lens     hiding ((.=))
 
-import qualified Data.Set           as Set
-import qualified Data.Text          as Text
-import qualified Data.HashMap.Lazy  as HM
-
-import Data.Aeson
-import Data.Aeson.Types
-
 import Servant
 import Servant.Client
 import Servant.Client.Core (requestPath)
 
-
+import Model.Types.Avs
-
--- | 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
-
 
 
 -------------

src/Utils/Lang.hs

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

src/Utils/Print.hs

@@ -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 :: (P.HasMeta p, Foldable t, P.ToMetaValue a) => t (Text, Maybe a) -> p -> p
-applyMetas metas doc = Fold.foldr (uncurry P.setMeta) doc metas
+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]) 
+      jobFullName          = unpack $ T.replace " " "-" (T.intercalate "_" . catMaybes $ [Just printJobName, nameQuali, nameCourse, nameSender, nameRecipient]) 
-      printJobFilename  = jobFullName <> ".pdf"
+      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
+          proc "pdftk"  [ "-"                     -- read from stdin
-                        , "output", "-"       -- write to stdout
+                        , "output", "-"           -- write to stdout
-                        , "user_pw", pw       -- encrypt pdf content
+                        , "user_pw", T.unpack pw  -- encrypt pdf content
-                        , "dont_ask"          -- no interaction
+                        , "dont_ask"              -- no interaction
-                        , "allow", "Printing" -- allow printing despite encryption
+                        , "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 -
 
-
+-- | Internal only, use `sendLetter` instead
--- 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
 lprPDF :: (MonadHandler m, HasAppSettings (HandlerSite m)) => String -> LBS.ByteString -> m (Either Text Text)
 lprPDF jb bs = do 
     lprServerArg <- $cachedHereBinary ("lprServer"::Text) getLprServerArg 

start.sh

@@ -22,6 +22,7 @@ export ALLOW_DEPRECATED=${ALLOW_DEPRECATED:-true}
 export ENCRYPT_ERRORS=${ENCRYPT_ERRORS:-false}
 export RIBBON=${RIBBON:-${__HOST:-localhost}}
 export APPROOT=${APPROOT:-http://localhost:$((${PORT_OFFSET:-0} + 3000))}
+export AVSPASS=${AVSPASS:-nopasswordset}
 unset HOST
 
 move-back() {

templates/letter/fraport_renewal.md

@@ -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.
+die Gültigkeit Ihres Vorfeldführerscheines läuft demnächst ab, am $expiry$.
-Durch die erfolgreiche Teilnahme an einem E-Lernen können Sie 
+Durch die erfolgreiche Teilnahme an einem E-Lernen können Sie die Gültigkeit
-die Gültigkeit um 2 Jahre verlängern. Verwenden Sie dazu die
+$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.
+your apron diving licence is about to expire soon, on $expiry$.
-You may renew your apron driving licence by two years through successfully 
+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

templates/mail/qualificationExpiry.hamlet

@@ -14,17 +14,21 @@ $newline never
       _{SomeMessage $ MsgMailSubjectQualificationExpiry qname}
 
     <p>
-      _{SomeMessage MsgMailAllocationNewCourseTip}
+      _{SomeMessage MsgMailBodyQualificationExpiry}      
-      <br />
-      <a href=@{QualificationR qualificationSchool qualificationShorthand}>
-        #{qualificationName}
-
-      #{nameHtml userDisplayName userSurname}
-      #{show qualificationUserValidUntil}
-      #{show qualificationUserFirstHeld}
 
     <p>
-      <h3> 
+      <dl>
-        EXPIRY
+        <dt>_{SomeMessage MsgQualificationName}
-      TODO: Diese Nachricht muss noch überarbeitet werden.
+        <dd>
+          <a href=@{QualificationR qualificationSchool qualificationShorthand}>
+            #{qualificationName}
+        <dt>_{SomeMessage MsgLmsUser}
+        <dd>#{nameHtml userDisplayName userSurname}
+        <dt>_{SomeMessage MsgLmsQualificationValidUntil}
+        <dd>#{expiryDate}
+
+    <p>
+      _{SomeMessage MsgLmsNoRenewal} 
+
+
     ^{ihamletSomeMessage editNotifications}

templates/mail/qualificationRenewal.hamlet

@@ -14,28 +14,21 @@ $newline never
       _{SomeMessage $ MsgMailSubjectQualificationRenewal qname}
 
     <p>
-      _{SomeMessage MsgMailLmsRenewalBody}
+      _{SomeMessage MsgMailBodyQualificationRenewal}      
-      <br />
-      <a href=@{QualificationR qualificationSchool qualificationShorthand}>
-        #{qualificationName}
-    
-    <p>
-      Name:
-      #{nameHtml userDisplayName userSurname}
 
     <p>
-      Qualifikation:
+      <dl>
-      #{qname}
+        <dt>_{SomeMessage MsgQualificationName}
-
+        <dd>
-    <p> 
+          <a href=@{QualificationR qualificationSchool qualificationShorthand}>
-      Gültig bis:
+            #{qualificationName}
-      #{show qualificationUserValidUntil}
+        <dt>_{SomeMessage MsgLmsUser}
-    <p> 
+        <dd>#{nameHtml userDisplayName userSurname}
-      Zuerst erhalten:
+        <dt>_{SomeMessage MsgLmsQualificationValidUntil}
-      #{show qualificationUserFirstHeld}
+        <dd>#{expiryDate}
 
     <p>
-      <h3>
+      _{SomeMessage MsgLmsRenewalInstructions}      
-        RENEWAL
+
-      TODO: Diese Nachricht muss noch überarbeitet werden.
+
     ^{ihamletSomeMessage editNotifications}

templates/profileData.hamlet

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

test/Database/Fill.hs

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

test/Handler/Utils/ExamSpec.hs

@@ -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
+test_spec :: Spec
-spec = do
+test_spec = do
     describe "examAutoOccurrence" $ do
         describe "Surname" $ testWithRule ExamRoomSurname
         describe "Matriculation" $ testWithRule ExamRoomMatriculation

test/Model/TypesSpec.hs

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

test/ModelSpec.hs

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

test/PandocSpec.hs

@@ -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 (fmap (second Just) x4)
-                      $ applyMetas x5
+                      $ 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
+      (ml, abMetaOriginal, blocks) <- generate arbitrary
-      let
+      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

test/User.hs

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

test/Utils/TypesSpec.hs

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