From 45daa5820e24a1dab6b19d4fba72b112600f58f4 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 4 Apr 2023 06:05:26 +0000 Subject: [PATCH 1/9] chore(i18n): matricle to avs number --- messages/uniworx/categories/authorization/de-de-formal.msg | 1 - messages/uniworx/categories/authorization/en-eu.msg | 1 - messages/uniworx/categories/courses/courses/de-de-formal.msg | 2 +- messages/uniworx/categories/courses/courses/en-eu.msg | 2 +- messages/uniworx/categories/user/de-de-formal.msg | 2 +- messages/uniworx/categories/user/en-eu.msg | 2 +- messages/uniworx/utils/table_column/en-eu.msg | 2 +- src/Foundation/Yesod/Auth.hs | 2 +- 8 files changed, 6 insertions(+), 8 deletions(-) diff --git a/messages/uniworx/categories/authorization/de-de-formal.msg b/messages/uniworx/categories/authorization/de-de-formal.msg index a5e4e744c..1c4416244 100644 --- a/messages/uniworx/categories/authorization/de-de-formal.msg +++ b/messages/uniworx/categories/authorization/de-de-formal.msg @@ -107,7 +107,6 @@ CampusUserInvalidDisplayName: Konnte anhand des Fraport Büko-Logins keinen voll CampusUserInvalidGivenName: Konnte anhand des Fraport Büko-Logins keinen Vornamen ermitteln CampusUserInvalidSurname: Konnte anhand des Fraport Büko-Logins keinen Nachname ermitteln CampusUserInvalidTitle: Konnte anhand des Fraport Büko-Logins keinen akademischen Titel ermitteln -CampusUserInvalidMatriculation: Konnte anhand des Fraport Büko-Logins keine Matrikelnummer ermitteln CampusUserInvalidFeaturesOfStudy parseErr@Text: Konnte anhand des Fraport Büko-Logins keine Studiengänge ermitteln CampusUserInvalidAssociatedSchools parseErr@Text: Konnte anhand des Fraport Büko-Logins keine Institute ermitteln InvalidCredentialsADNoSuchObject: Benutzereintrag existiert nicht diff --git a/messages/uniworx/categories/authorization/en-eu.msg b/messages/uniworx/categories/authorization/en-eu.msg index 489a2e6ca..b1676fc75 100644 --- a/messages/uniworx/categories/authorization/en-eu.msg +++ b/messages/uniworx/categories/authorization/en-eu.msg @@ -108,7 +108,6 @@ CampusUserInvalidDisplayName: Could not determine display name during Fraport B CampusUserInvalidGivenName: Could not determine given name during Fraport Büko login CampusUserInvalidSurname: Could not determine surname during Fraport Büko login CampusUserInvalidTitle: Could not determine title during Fraport Büko login -CampusUserInvalidMatriculation: Could not determine matriculation during Fraport Büko login CampusUserInvalidFeaturesOfStudy parseErr: Could not determine features of study during Fraport Büko login CampusUserInvalidAssociatedSchools parseErr: Could not determine associated departments during Fraport Büko login InvalidCredentialsADNoSuchObject: User entry does not exist diff --git a/messages/uniworx/categories/courses/courses/de-de-formal.msg b/messages/uniworx/categories/courses/courses/de-de-formal.msg index 939bb0659..fa44ab8cc 100644 --- a/messages/uniworx/categories/courses/courses/de-de-formal.msg +++ b/messages/uniworx/categories/courses/courses/de-de-formal.msg @@ -132,7 +132,7 @@ CourseUserTutorials: Angemeldete Tutorien CourseUserExams: Angemeldete Prüfungen CourseUserSheets: Übungsblätter CsvColumnUserName: Voller Name des/der Teilnehmers/Teilnehmerin -CsvColumnUserMatriculation: Matrikelnummer des/der Teilnehmers/Teilnehmerin +CsvColumnUserMatriculation: AVS Nummer des/der Teilnehmers/Teilnehmerin CsvColumnUserSex: Geschlecht CsvColumnUserBirthday: Geburtstag CsvColumnUserEmail: E-Mail-Adresse des/der Teilnehmers/Teilnehmerin diff --git a/messages/uniworx/categories/courses/courses/en-eu.msg b/messages/uniworx/categories/courses/courses/en-eu.msg index 0625c9ccc..ae25a7187 100644 --- a/messages/uniworx/categories/courses/courses/en-eu.msg +++ b/messages/uniworx/categories/courses/courses/en-eu.msg @@ -132,7 +132,7 @@ CourseUserTutorials: Registered tutorials CourseUserExams: Registered exams CourseUserSheets: Exercise sheets CsvColumnUserName: Participant's full name -CsvColumnUserMatriculation: Participant's matriculation +CsvColumnUserMatriculation: Participant's AVS number CsvColumnUserSex: Participant's sex CsvColumnUserBirthday: Birthday CsvColumnUserEmail: Participant's email address diff --git a/messages/uniworx/categories/user/de-de-formal.msg b/messages/uniworx/categories/user/de-de-formal.msg index 85ef0f47b..ab6cdb32b 100644 --- a/messages/uniworx/categories/user/de-de-formal.msg +++ b/messages/uniworx/categories/user/de-de-formal.msg @@ -11,7 +11,7 @@ AdminUserDisplayEmail: E-Mail-Adresse AdminUserIdent: Identifikation AdminUserAuth: Authentifizierung AdminUserAuthTooltip: Abhängig von der Auswahl werden neue Benutzer über ihr neues FRADrive Konto benachrichtigt. -AdminUserMatriculation: Matrikelnummer +AdminUserMatriculation: AVS Nummer AdminUserSex: Geschlecht AdminUserBirthday: Geburtsdatum AdminUserTelephone: Telefonnummer diff --git a/messages/uniworx/categories/user/en-eu.msg b/messages/uniworx/categories/user/en-eu.msg index 8fd7c0333..64145dcaf 100644 --- a/messages/uniworx/categories/user/en-eu.msg +++ b/messages/uniworx/categories/user/en-eu.msg @@ -11,7 +11,7 @@ AdminUserDisplayEmail: Email address AdminUserIdent: Identification AdminUserAuth: Authentication AdminUserAuthTooltip: New users may be notified about their FRADrive account depending on this choice. -AdminUserMatriculation: Matriculation +AdminUserMatriculation: AVS number AdminUserSex: Sex AdminUserBirthday: Date of Birth AdminUserTelephone: Phone diff --git a/messages/uniworx/utils/table_column/en-eu.msg b/messages/uniworx/utils/table_column/en-eu.msg index 642837c6d..6eeed21d1 100644 --- a/messages/uniworx/utils/table_column/en-eu.msg +++ b/messages/uniworx/utils/table_column/en-eu.msg @@ -56,7 +56,7 @@ TableTutorialDeregisterUntil: Deregister until TableActionsHead: Actions TableTutorialTime: Time TableNoFilter: No restriction -TableUserMatriculation: AVS Number +TableUserMatriculation: AVS number TableColumnStudyFeatures: Features of study TableSchoolShort: Shorthand TableSchoolName: Name diff --git a/src/Foundation/Yesod/Auth.hs b/src/Foundation/Yesod/Auth.hs index aaa04294d..b3fbced9b 100644 --- a/src/Foundation/Yesod/Auth.hs +++ b/src/Foundation/Yesod/Auth.hs @@ -127,7 +127,7 @@ data CampusUserConversionException | CampusUserInvalidGivenName | CampusUserInvalidSurname | CampusUserInvalidTitle - | CampusUserInvalidMatriculation + -- | CampusUserInvalidMatriculation | CampusUserInvalidFeaturesOfStudy Text | CampusUserInvalidAssociatedSchools Text deriving (Eq, Ord, Read, Show, Generic) From a827f46f0fca0d0c5e198af36eb96dabfbb9c7a3 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 4 Apr 2023 11:52:21 +0000 Subject: [PATCH 2/9] chore(letter): implement course qualification letter (wip) --- src/Handler/SAP.hs | 12 +++--- src/Handler/Utils/Profile.hs | 17 ++++++--- src/Model/Types/DateTime.hs | 14 +++++++ src/Utils/Lens.hs | 3 ++ src/Utils/Print.hs | 1 + src/Utils/Print/RenewQualification.hs | 2 +- templates/letter/fraport_qualification.md | 45 ++++++++++++++++++++++- 7 files changed, 81 insertions(+), 13 deletions(-) diff --git a/src/Handler/SAP.hs b/src/Handler/SAP.hs index 368baebbf..5365b00fd 100644 --- a/src/Handler/SAP.hs +++ b/src/Handler/SAP.hs @@ -13,6 +13,7 @@ import Import import Handler.Utils import Handler.Utils.Csv +import Handler.Utils.Profile -- import qualified Data.CaseInsensitive as CI import qualified Data.Csv as Csv @@ -56,11 +57,11 @@ instance ToNamedRecord SapUserTableCsv where -- | Removes all personalNummer which are not numbers between 10000 and 99999 (also excludes E-Accounts), which should not be returned by the query anyway (only qualfications with sap id and users with internal personnel number must be transmitted) -- TODO: once temporary suspensions are implemented, a user must be transmitted to SAP in two rows: firstheld->suspensionFrom & suspensionTo->validTo sapRes2csv :: [(Ex.Value (Maybe Text), Ex.Value Day, Ex.Value Day, Ex.Value (Maybe Text))] -> [SapUserTableCsv] -sapRes2csv l = [ res | (Ex.Value (Just persNo), Ex.Value firstHeld, Ex.Value validUntil, Ex.Value (Just sapId)) <- l - , let persNoAsInt = readMay persNo - , persNoAsInt >= Just (10000::Int) -- filter E-accounts for SAP export - , persNoAsInt <= Just (99999::Int) -- filter E-accounts for SAP export - , let res = SapUserTableCsv +sapRes2csv l = [ res | (Ex.Value pn@(Just persNo), Ex.Value firstHeld, Ex.Value validUntil, Ex.Value (Just sapId)) <- l + -- , let persNoAsInt = readMay =<< persNo -- also see Handler.Utils.Profile.validFraportPersonalNumber + -- , persNoAsInt >= Just (10000::Int) -- filter E-accounts for SAP export + -- , persNoAsInt <= Just (99999::Int) -- filter E-accounts for SAP export + , let res = SapUserTableCsv { csvSUTpersonalNummer = persNo , csvSUTqualifikation = sapId , csvSUTgültigVon = firstHeld @@ -68,6 +69,7 @@ sapRes2csv l = [ res | (Ex.Value (Just persNo), Ex.Value firstHeld, Ex.Value val -- , csvSUTsupendiertBis = blocked , csvSUTausprägung = "J" } + , validFraportPersonalNumber pn ] -- | Deliver all employess with a successful LDAP synch within the last 3 months diff --git a/src/Handler/Utils/Profile.hs b/src/Handler/Utils/Profile.hs index 22f7a8098..d473bd54d 100644 --- a/src/Handler/Utils/Profile.hs +++ b/src/Handler/Utils/Profile.hs @@ -5,12 +5,10 @@ -- TODO: why is this Handler.Utils.Profile instead of Utils.Profile? -- TODO: consider merging with Handler.Utils.Users? module Handler.Utils.Profile - ( checkDisplayName - , validDisplayName - , fixDisplayName + ( validDisplayName, checkDisplayName, fixDisplayName , validPostAddress - , validEmail, validEmail' - , pickValidEmail, pickValidEmail' + , validEmail, validEmail', pickValidEmail, pickValidEmail' + , validFraportPersonalNumber ) where import Import.NoFoundation @@ -103,4 +101,11 @@ pickValidEmail' :: UserEmail -> UserEmail -> Maybe UserEmail pickValidEmail' x y | validEmail' x = Just x | validEmail' y = Just y - | otherwise = Nothing \ No newline at end of file + | otherwise = Nothing + +validFraportPersonalNumber :: Maybe Text -> Bool +validFraportPersonalNumber Nothing = False +validFraportPersonalNumber (Just t) + | (Just pn) <- readMay t + = pn >= (10000::Int) && pn <= (99999::Int) -- used to filter for SAP export + | otherwise = False diff --git a/src/Model/Types/DateTime.hs b/src/Model/Types/DateTime.hs index a3ffb0ff6..f36420657 100644 --- a/src/Model/Types/DateTime.hs +++ b/src/Model/Types/DateTime.hs @@ -15,6 +15,7 @@ module Model.Types.DateTime import Import.NoModel +import qualified Data.Set as Set import Data.Ratio ((%)) import qualified Data.Text as Text -- import Data.Either.Combinators (maybeToRight, mapLeft) @@ -206,3 +207,16 @@ derivePersistFieldJSON ''Occurrences nullaryPathPiece ''DayOfWeek camelToPathPiece + + +-- | Get bounds for an Occurrences +-- TODO: unfinished function, only works for a few selected cases yet +occurrencesBounds :: Occurrences -> (Maybe Day, Maybe Day) +occurrencesBounds Occurrences{occurrencesScheduled=scd} | notNull scd = (Nothing, Nothing) -- TODO: case is not yet implemented +occurrencesBounds Occurrences{occurrencesExceptions=exc} = (Set.lookupMin occDays, Set.lookupMax occDays) + where + occDays = Set.foldr getOccDays mempty exc + + getOccDays :: OccurrenceException -> Set Day -> Set Day + getOccDays ExceptNoOccur{} acc = acc -- TODO: this case ignores ExceptNoOccur for now! + getOccDays ExceptOccur{exceptDay} acc = Set.insert exceptDay acc diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index aaa7aa63a..8d8108ee5 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -128,6 +128,9 @@ makeClassyFor_ ''LmsResult makeClassyFor_ ''UserAvs makeClassyFor_ ''UserAvsCard +makeClassyFor_ ''UserCompany +makeLenses_ ''Company + _entityKey :: Getter (Entity record) (Key record) -- ^ Not a `Lens'` for safety _entityKey = to entityKey diff --git a/src/Utils/Print.hs b/src/Utils/Print.hs index 55b81a0c8..7d2d46374 100644 --- a/src/Utils/Print.hs +++ b/src/Utils/Print.hs @@ -47,6 +47,7 @@ import Jobs.Handler.SendNotification.Utils import Utils.Print.Letters import Utils.Print.RenewQualification +import Utils.Print.CourseCertificate -- import Model.Types.Markup -- TODO-QSV: should this module be moved accordingly? diff --git a/src/Utils/Print/RenewQualification.hs b/src/Utils/Print/RenewQualification.hs index 55496a840..f8228e036 100644 --- a/src/Utils/Print/RenewQualification.hs +++ b/src/Utils/Print/RenewQualification.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Steffen Jost +-- SPDX-FileCopyrightText: 2023 Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later diff --git a/templates/letter/fraport_qualification.md b/templates/letter/fraport_qualification.md index c29c2deb0..2b75d9571 100644 --- a/templates/letter/fraport_qualification.md +++ b/templates/letter/fraport_qualification.md @@ -8,8 +8,51 @@ date: 11.11.1111 ... $if(is-de)$ +# Teilnahmebescheinigung + +## $participant$ + +$if(fra-number)$ + ### $fra-number$ $fra-department$ +$endif$ + +$if(company)$ + ### $company$ +$endif$ + +Hat +$if(course-begin)$ +von $course-begin$ bis $course-end$ +$endif$ +an der Veranstaltung + +## $course-name$ + +der Fahrerausbildung der Fraport AG teilgenommen. + +$if(course-content)$ + ### Inhalte: + + $course-content$ +$endif$ + +Mit Aushändigung der Teilnahmebescheinigung wird der erfolgreiche Abschluss des Kurses bestätigt. +Dieses Zertifikat wurde maschinell erstellt. + + +Frankfurt am Main, $date$ + +Fraport College + $else$ - \ No newline at end of file + + +# Certificate of attendance + +**English version is not yet implemened.** +TODO + +$endif$ \ No newline at end of file From 5c11664830bb127e1daa67b003bdbad16fa65347 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 5 Apr 2023 07:35:35 +0000 Subject: [PATCH 3/9] chore(letter): implement course qualification letter (done) --- src/Utils/Print.hs | 3 ++- src/Utils/Print/Letters.hs | 17 ++++++++++++++--- src/Utils/Print/RenewQualification.hs | 12 +++++++----- 3 files changed, 23 insertions(+), 9 deletions(-) diff --git a/src/Utils/Print.hs b/src/Utils/Print.hs index 7d2d46374..3b9bc611e 100644 --- a/src/Utils/Print.hs +++ b/src/Utils/Print.hs @@ -16,6 +16,7 @@ module Utils.Print , toMeta, mbMeta -- single values , mkMeta, appMeta, applyMetas -- multiple values , LetterRenewQualificationF(..) + , LetterCourseCertificate(), makeCourseCertificates ) where -- import Import.NoModel @@ -218,7 +219,7 @@ printLetter'' _ = do } -} -sendEmailOrLetter :: (MDLetter l) => UserId -> l -> Handler Bool +sendEmailOrLetter :: (MDLetter l, MDMail l) => UserId -> l -> Handler Bool sendEmailOrLetter recipient letter = do (underling, receivers, undercopy) <- updateReceivers recipient -- TODO: check to avoid this almost circular dependency now <- liftIO getCurrentTime diff --git a/src/Utils/Print/Letters.hs b/src/Utils/Print/Letters.hs index 9a92a1ea8..dad257c4d 100644 --- a/src/Utils/Print/Letters.hs +++ b/src/Utils/Print/Letters.hs @@ -36,6 +36,8 @@ import Handler.Utils.DateTime -- import Model.Types.Markup -- TODO-QSV: should this module be moved accordingly? +-- instance P.ToMetaValue (CI Text) where +-- toMetaValue = P.MetaString . CI.original ---------------------- -- Pandoc Functions -- @@ -218,8 +220,6 @@ data EncryptPDFfor = NoPassword | PasswordSupervisor | PasswordUnderling deriving (Eq, Show) class MDLetter l where - getMailSubject :: l -> SomeMessage UniWorX -- only used if letter is sent by email as pdf attachment - getMailBody :: l -> DateTimeFormatter -> HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX) -- only used if letter is sent by email as pdf attachment letterMeta :: l -> DateTimeFormatter -> Lang -> Entity User -> P.Meta getPJId :: l -> PrintJobIdentification getLetterEnvelope :: l -> Char @@ -238,4 +238,15 @@ addApcIdent = P.Meta . toMeta "apc-ident" getApcIdent :: P.Meta -> Maybe Text getApcIdent (P.lookupMeta "apc-ident" -> Just (P.MetaString t)) = Just t -getApcIdent _ = Nothing \ No newline at end of file +getApcIdent _ = Nothing + + +---------------- +-- Mail Class -- +---------------- + +-- this is for letters that may alternatively be sent as attachments to emails + +class MDMail l where + getMailSubject :: l -> SomeMessage UniWorX -- only used if letter is sent by email as pdf attachment + getMailBody :: l -> DateTimeFormatter -> HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX) -- only used if letter is sent by email as pdf attachment diff --git a/src/Utils/Print/RenewQualification.hs b/src/Utils/Print/RenewQualification.hs index f8228e036..c8723035a 100644 --- a/src/Utils/Print/RenewQualification.hs +++ b/src/Utils/Print/RenewQualification.hs @@ -45,16 +45,18 @@ letterRenewalQualificationFData LetterRenewQualificationF{lmsLogin} = LetterRene lmsUrl = "https://drive.fraport.de" lmsUrlLogin = lmsUrl <> "/?login=" <> lmsIdent lmsIdent = getLmsIdent lmsLogin - + +instance MDMail LetterRenewQualificationF where + getMailSubject l = SomeMessage $ MsgMailSubjectQualificationRenewal $ qualShort l + getMailBody l@LetterRenewQualificationF{..} DateTimeFormatter{ format } = + let LetterRenewQualificationFData{..} = letterRenewalQualificationFData l + in $(ihamletFile "templates/mail/body/qualificationRenewal.hamlet") + instance MDLetter LetterRenewQualificationF where encrypPDFfor _ = PasswordUnderling getLetterKind _ = PinLetter getLetterEnvelope l = maybe 'q' (Char.toLower . fst) $ Text.uncons (qualShort l) getTemplate _ = decodeUtf8 $(Data.FileEmbed.embedFile "templates/letter/fraport_renewal.md") - getMailSubject l = SomeMessage $ MsgMailSubjectQualificationRenewal $ qualShort l - getMailBody l@LetterRenewQualificationF{..} DateTimeFormatter{ format } = - let LetterRenewQualificationFData{..} = letterRenewalQualificationFData l - in $(ihamletFile "templates/mail/body/qualificationRenewal.hamlet") letterMeta l@LetterRenewQualificationF{..} DateTimeFormatter{ format } _lang Entity{entityKey=rcvrId, entityVal=User{userDisplayName}} = let LetterRenewQualificationFData{..} = letterRenewalQualificationFData l From b3f01ba3b103b3c0f71dd48cb2682325e5d212b3 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 5 Apr 2023 07:47:30 +0000 Subject: [PATCH 4/9] chore(letter): allow letter language to be fixed by MDLetter instance --- src/Utils/Print.hs | 4 ++-- src/Utils/Print/Letters.hs | 5 +++-- src/Utils/Print/RenewQualification.hs | 5 +++-- 3 files changed, 8 insertions(+), 6 deletions(-) diff --git a/src/Utils/Print.hs b/src/Utils/Print.hs index 3b9bc611e..c71b681c5 100644 --- a/src/Utils/Print.hs +++ b/src/Utils/Print.hs @@ -142,8 +142,8 @@ renderLetter rcvrEnt@Entity{entityVal=rcvr} mdl apcIdent = do meta = addApcIdent apcIdent <> letterMeta mdl formatter lang rcvrEnt <> mkMeta - [ toMeta "lang" lang - , toMeta "date" $ format SelFormatDate now + [ -- toMeta "lang" lang -- receiver language is decided in MDLetter instance, since some letters have fixed languages + toMeta "date" $ format SelFormatDate now , toMeta "rcvr-name" $ rcvr & userDisplayName , toMeta "address" $ fromMaybe [rcvr & userDisplayName] $ getPostalAddress rcvr --, toMeta "rcvr-email" $ rcvr & userDisplayEmail -- note that some templates use "email" already otherwise diff --git a/src/Utils/Print/Letters.hs b/src/Utils/Print/Letters.hs index dad257c4d..58b57675e 100644 --- a/src/Utils/Print/Letters.hs +++ b/src/Utils/Print/Letters.hs @@ -220,7 +220,8 @@ data EncryptPDFfor = NoPassword | PasswordSupervisor | PasswordUnderling deriving (Eq, Show) class MDLetter l where - letterMeta :: l -> DateTimeFormatter -> Lang -> Entity User -> P.Meta + letterMeta :: l -> DateTimeFormatter -> Lang -> Entity User -> P.Meta -- formatter/lang for individual receiver, set Meta "lang" for individually translated letters + -- NOTE: METAs "date", "rcvr-name", "address" are set automatically by renderLetter for each receiver getPJId :: l -> PrintJobIdentification getLetterEnvelope :: l -> Char getLetterKind :: Proxy l -> LetterKind @@ -247,6 +248,6 @@ getApcIdent _ = Nothing -- this is for letters that may alternatively be sent as attachments to emails -class MDMail l where +class MDMail l where -- getMailSubject :: l -> SomeMessage UniWorX -- only used if letter is sent by email as pdf attachment getMailBody :: l -> DateTimeFormatter -> HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX) -- only used if letter is sent by email as pdf attachment diff --git a/src/Utils/Print/RenewQualification.hs b/src/Utils/Print/RenewQualification.hs index c8723035a..537a8d8a8 100644 --- a/src/Utils/Print/RenewQualification.hs +++ b/src/Utils/Print/RenewQualification.hs @@ -58,7 +58,7 @@ instance MDLetter LetterRenewQualificationF where getLetterEnvelope l = maybe 'q' (Char.toLower . fst) $ Text.uncons (qualShort l) getTemplate _ = decodeUtf8 $(Data.FileEmbed.embedFile "templates/letter/fraport_renewal.md") - letterMeta l@LetterRenewQualificationF{..} DateTimeFormatter{ format } _lang Entity{entityKey=rcvrId, entityVal=User{userDisplayName}} = + letterMeta l@LetterRenewQualificationF{..} DateTimeFormatter{ format } lang Entity{entityKey=rcvrId, entityVal=User{userDisplayName}} = let LetterRenewQualificationFData{..} = letterRenewalQualificationFData l isSupervised = rcvrId /= qualHolderID in mkMeta $ @@ -67,7 +67,8 @@ instance MDLetter LetterRenewQualificationF where , toMeta "de-opening" ("Sehr geehrte Damen und Herren,"::Text) , toMeta "en-opening" ("Dear Sir or Madam,"::Text) ] <> - [ toMeta "login" lmsIdent + [ toMeta "lang" lang + , toMeta "login" lmsIdent , toMeta "pin" lmsPin , toMeta "examinee" qualHolderDN , toMeta "expiry" (format SelFormatDate qualExpiry) From db0eadc746fca6617a662d53f65a41acd1a8c19e Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 5 Apr 2023 11:13:53 +0000 Subject: [PATCH 5/9] chore(letter): print certificates linked to tutorium --- src/Handler/Tutorial/Users.hs | 29 +++++++--- src/Utils/Print/CourseCertificate.hs | 85 ++++++++++++++++++++++++++++ templates/letter/plain_article.latex | 9 +-- 3 files changed, 110 insertions(+), 13 deletions(-) create mode 100644 src/Utils/Print/CourseCertificate.hs diff --git a/src/Handler/Tutorial/Users.hs b/src/Handler/Tutorial/Users.hs index ae3330ba3..b66527596 100644 --- a/src/Handler/Tutorial/Users.hs +++ b/src/Handler/Tutorial/Users.hs @@ -11,6 +11,7 @@ module Handler.Tutorial.Users import Import import Utils.Form +import Utils.Print import Handler.Utils import Handler.Utils.Course import Handler.Utils.Tutorial @@ -20,7 +21,7 @@ import qualified Data.CaseInsensitive as CI import qualified Data.Set as Set import qualified Data.Map as Map - +import qualified Data.ByteString.Lazy as LBS -- import qualified Data.Time.Zones as TZ import Database.Esqueleto.Experimental ((:&)(..)) @@ -57,13 +58,13 @@ data TutorialUserActionData deriving (Eq, Ord, Read, Show, Generic) -getTUsersR, postTUsersR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> Handler Html +getTUsersR, postTUsersR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> Handler TypedContent getTUsersR = postTUsersR postTUsersR tid ssh csh tutn = do showSex <- getShowSex - (Entity tutid Tutorial{..}, (participantRes, participantTable), qualifications) <- runDB $ do + (Entity tutid tut@Tutorial{..}, (participantRes, participantTable), qualifications) <- runDB $ do cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh - tut@(Entity tutid _) <- fetchTutorial tid ssh csh tutn + tutEnt@(Entity tutid _) <- fetchTutorial tid ssh csh tutn qualifications <- getCourseQualifications cid now <- liftIO getCurrentTime let minDur :: Maybe Int = minimumMaybe $ catMaybes (view _qualificationValidDuration <$> qualifications) -- no instance Ord CalendarDiffDays @@ -118,14 +119,23 @@ postTUsersR tid ssh csh tutn = do , ( TutorialUserDeregister, pure TutorialUserDeregisterData ) ] table <- makeCourseUserTable cid acts isInTut colChoices psValidator (Just csvColChoices) - return (tut, table, qualifications) + return (tutEnt, table, qualifications) let courseQids = Set.fromList (entityKey <$> qualifications) formResult participantRes $ \case - (TutorialUserPrintQualificationData{..}, _selectedUsers) + (TutorialUserPrintQualificationData{..}, selectedUsers) | tuQualification `Set.member` courseQids -> do - -- TODO Continue here - addMessageI Error MsgErrorUnknownFormAction + rcvr <- requireAuth + letters <- runDB $ makeCourseCertificates tut Nothing $ toList selectedUsers + now <- liftIO getCurrentTime + case letters of + [l] -> do + encRcvr <- encrypt $ entityKey rcvr + apcIdent <- letterApcIdent l encRcvr now + renderLetter rcvr l apcIdent >>= \case + Left err -> sendResponseStatus internalServerError500 $ "PDF generation failed: \n" <> err + Right pdf -> void $ sendByteStringAsFile "demoPDF.pdf" (LBS.toStrict pdf) now + _ -> addMessageI Error MsgErrorUnknownFormAction (TutorialUserGrantQualificationData{..}, selectedUsers) | tuQualification `Set.member` courseQids -> do -- today <- localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime @@ -158,6 +168,7 @@ postTUsersR tid ssh csh tutn = do return user let heading = prependCourseTitle tid ssh csh $ CI.original tutorialName - siteLayoutMsg heading $ do + html <- siteLayoutMsg heading $ do setTitleI heading $(widgetFile "tutorial-participants") + return $ toTypedContent html diff --git a/src/Utils/Print/CourseCertificate.hs b/src/Utils/Print/CourseCertificate.hs new file mode 100644 index 000000000..5a6ad5482 --- /dev/null +++ b/src/Utils/Print/CourseCertificate.hs @@ -0,0 +1,85 @@ +-- SPDX-FileCopyrightText: 2023 Steffen Jost +-- +-- SPDX-License-Identifier: AGPL-3.0-or-later + +{-# OPTIONS_GHC -fno-warn-unused-top-binds #-} + +module Utils.Print.CourseCertificate where + +import Import + +-- import Data.Char as Char +-- import qualified Data.Text as Text +import qualified Data.CaseInsensitive as CI + +import Data.FileEmbed (embedFile) + +import Utils.Print.Letters +import Handler.Utils.Profile + +data LetterCourseCertificate = LetterCourseCertificate + { ccCourseId :: CourseId + , ccCourseName :: Text + -- , ccTutorialName :: Text + , ccCourseContent :: Maybe [Text] + , ccCourseBegin :: Maybe Day + , ccCourseEnd :: Maybe Day + , ccCourseLang :: Maybe Lang -- maybe fix language to fit course content language + , ccParticipant :: UserDisplayName + , ccFraNumber :: Maybe Text + , ccFraDepartment :: Maybe Text + , ccCompany :: Maybe Text + } + deriving (Eq, Show) + + +instance MDLetter LetterCourseCertificate where + encrypPDFfor _ = NoPassword + getLetterKind _ = Plain + getLetterEnvelope _ = 'c' + getTemplate _ = decodeUtf8 $(Data.FileEmbed.embedFile "templates/letter/fraport_qualification.md") + + letterMeta LetterCourseCertificate{..} DateTimeFormatter{ format } lang _rcvrEnt = + mkMeta + [ toMeta "participant" ccParticipant + , mbMeta "fra-number" ccFraNumber + , mbMeta "fra-department" ccFraDepartment + , mbMeta "company" ccCompany + , toMeta "course-name" ccCourseName + , mbMeta "course-content" ccCourseContent + , mbMeta "course-begin" (format SelFormatDate <$> ccCourseBegin) + , mbMeta "course-end" (format SelFormatDate <$> ccCourseEnd) + , toMeta "lang" (fromMaybe lang ccCourseLang) + ] + + getPJId LetterCourseCertificate{..} = + PrintJobIdentification + { pjiName = "Certificate" + , pjiApcAcknowledge = "cc-" <> ccCourseName + , pjiRecipient = Nothing + , pjiSender = Nothing + , pjiCourse = Just ccCourseId + , pjiQualification = Nothing + , pjiLmsUser = Nothing + } + + +makeCourseCertificates :: Traversable t => Tutorial -> Maybe Lang -> t UserId -> DB (t LetterCourseCertificate) +makeCourseCertificates tut ccCourseLang participants = do + let ccCourseId = tut ^. _tutorialCourse + Course{courseName, courseDescription} <- get404 ccCourseId + let ccCourseName = CI.original courseName + ccCourseContent = html2textlines <$> courseDescription + (ccCourseBegin, ccCourseEnd) = occurrencesBounds $ tut ^. _tutorialTime + forM participants $ \uid -> do + User{userDisplayName=ccParticipant, userCompanyDepartment, userCompanyPersonalNumber} <- get404 uid + (ccFraNumber, ccFraDepartment, ccCompany) <- + if isJust userCompanyDepartment && validFraportPersonalNumber userCompanyPersonalNumber + then + return (userCompanyPersonalNumber, userCompanyDepartment, Nothing) + else do + usrComp <- selectFirst [UserCompanyUser ==. uid] [Desc UserCompanyId] + comp <- forM usrComp (get . userCompanyCompany . entityVal) + let res = (comp ^? _Just . _Just . _companyName . _CI) <|> userCompanyDepartment -- if there is no company, use the department as fallback, if possible + return (Nothing, Nothing, res) + return LetterCourseCertificate{..} diff --git a/templates/letter/plain_article.latex b/templates/letter/plain_article.latex index ba833c37b..7d3bf4316 100644 --- a/templates/letter/plain_article.latex +++ b/templates/letter/plain_article.latex @@ -1,8 +1,9 @@ %Based upon https://github.com/benedictdudel/pandoc-letter-din5008 \documentclass[ paper=A4, + version=last, firstfoot=false % first-page footer -]{scrlttr2} +]{scrartcl} \PassOptionsToPackage{hyphens}{url} \PassOptionsToPackage{unicode$for(hyperrefoptions)$,$hyperrefoptions$$endfor$}{hyperref} @@ -84,9 +85,9 @@ $endif$ \usepackage{enumitem} -\setlength{\oddsidemargin}{\useplength{toaddrhpos}} -\addtolength{\oddsidemargin}{-1in} -\setlength{\textwidth}{\useplength{firstheadwidth}} +%\setlength{\oddsidemargin}{\useplength{toaddrhpos}} +%\addtolength{\oddsidemargin}{-1in} +%\setlength{\textwidth}{\useplength{firstheadwidth}} \usepackage[absolute,quiet,overlay]{textpos}%,showboxes \setlength{\TPHorizModule}{1mm} From 879b8a72bebd928dd6a2600a941d5ac505343a41 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 5 Apr 2023 16:10:53 +0000 Subject: [PATCH 6/9] chore(letter): improve certificate interpolation and styling --- src/Handler/Tutorial/Users.hs | 7 +++- src/Utils/Print.hs | 2 +- src/Utils/Print/CourseCertificate.hs | 5 ++- src/Utils/Print/Letters.hs | 2 +- templates/letter/fraport_qualification.md | 50 ++++++++++++++++------- templates/letter/plain_article.latex | 5 ++- test/Database/Fill.hs | 10 ++--- 7 files changed, 55 insertions(+), 26 deletions(-) diff --git a/src/Handler/Tutorial/Users.hs b/src/Handler/Tutorial/Users.hs index b66527596..2a3a12987 100644 --- a/src/Handler/Tutorial/Users.hs +++ b/src/Handler/Tutorial/Users.hs @@ -21,7 +21,7 @@ import qualified Data.CaseInsensitive as CI import qualified Data.Set as Set import qualified Data.Map as Map -import qualified Data.ByteString.Lazy as LBS +-- import qualified Data.ByteString.Lazy as LBS -- import qualified Data.Time.Zones as TZ import Database.Esqueleto.Experimental ((:&)(..)) @@ -134,7 +134,10 @@ postTUsersR tid ssh csh tutn = do apcIdent <- letterApcIdent l encRcvr now renderLetter rcvr l apcIdent >>= \case Left err -> sendResponseStatus internalServerError500 $ "PDF generation failed: \n" <> err - Right pdf -> void $ sendByteStringAsFile "demoPDF.pdf" (LBS.toStrict pdf) now + Right pdf -> do -- void $ sendByteStringAsFile "demoPDF.pdf" (LBS.toStrict pdf) now + let typePDF :: ContentType + typePDF = "application/pdf" + sendResponse (typePDF, toContent pdf) _ -> addMessageI Error MsgErrorUnknownFormAction (TutorialUserGrantQualificationData{..}, selectedUsers) | tuQualification `Set.member` courseQids -> do diff --git a/src/Utils/Print.hs b/src/Utils/Print.hs index c71b681c5..e019e5557 100644 --- a/src/Utils/Print.hs +++ b/src/Utils/Print.hs @@ -138,7 +138,7 @@ renderLetter rcvrEnt@Entity{entityVal=rcvr} mdl apcIdent = do formatter@DateTimeFormatter{ format } <- getDateTimeFormatterUser' rcvr let lang = selectDeEn $ rcvr & userLanguages -- select either German or English only, default de; see Utils.Lang kind = getLetterKind $ pure mdl - tmpl = getTemplate $ pure mdl + tmpl = getTemplate mdl meta = addApcIdent apcIdent <> letterMeta mdl formatter lang rcvrEnt <> mkMeta diff --git a/src/Utils/Print/CourseCertificate.hs b/src/Utils/Print/CourseCertificate.hs index 5a6ad5482..9f32946cb 100644 --- a/src/Utils/Print/CourseCertificate.hs +++ b/src/Utils/Print/CourseCertificate.hs @@ -9,7 +9,7 @@ module Utils.Print.CourseCertificate where import Import -- import Data.Char as Char --- import qualified Data.Text as Text +import qualified Data.Text as Text import qualified Data.CaseInsensitive as CI import Data.FileEmbed (embedFile) @@ -37,6 +37,9 @@ instance MDLetter LetterCourseCertificate where encrypPDFfor _ = NoPassword getLetterKind _ = Plain getLetterEnvelope _ = 'c' + getTemplate LetterCourseCertificate{ccCourseContent = Just ccc} = + Text.replace "%%%course-content%%%" (unlines ccc) $ + decodeUtf8 $(Data.FileEmbed.embedFile "templates/letter/fraport_qualification.md") getTemplate _ = decodeUtf8 $(Data.FileEmbed.embedFile "templates/letter/fraport_qualification.md") letterMeta LetterCourseCertificate{..} DateTimeFormatter{ format } lang _rcvrEnt = diff --git a/src/Utils/Print/Letters.hs b/src/Utils/Print/Letters.hs index 58b57675e..19b0549cd 100644 --- a/src/Utils/Print/Letters.hs +++ b/src/Utils/Print/Letters.hs @@ -225,7 +225,7 @@ class MDLetter l where getPJId :: l -> PrintJobIdentification getLetterEnvelope :: l -> Char getLetterKind :: Proxy l -> LetterKind - getTemplate :: Proxy l -> Text + getTemplate :: l -> Text encrypPDFfor :: Proxy l -> EncryptPDFfor letterApcIdent :: (MDLetter l, MonadHandler m) => l -> CryptoUUIDUser -> UTCTime -> m Text diff --git a/templates/letter/fraport_qualification.md b/templates/letter/fraport_qualification.md index 2b75d9571..7402d9cd5 100644 --- a/templates/letter/fraport_qualification.md +++ b/templates/letter/fraport_qualification.md @@ -1,49 +1,69 @@ --- ### Metaddaten, welche hier eingestellt werden: - +# keine ### Metadaten, welche automatisch ersetzt werden: lang: de-de is-de: true date: 11.11.1111 +test1: this **is really** a test +test2: 'this **is another** test' +test3: | +

First

+

Here is some text with emphasis to see. ... +\renewcommand{\familydefault}{\sfdefault} $if(is-de)$ -# Teilnahmebescheinigung +\medskip -## $participant$ +\begin{huge}\sffamily\textbf{Teilnahmebescheinigung}\end{huge} +\vspace{\fill} + +# $participant$ {-} $if(fra-number)$ - ### $fra-number$ $fra-department$ +## $fra-number$ $fra-department$ {-} $endif$ - $if(company)$ - ### $company$ +## $company$ {-} $endif$ - -Hat +hat $if(course-begin)$ von $course-begin$ bis $course-end$ $endif$ an der Veranstaltung - -## $course-name$ - +\centerline{\sffamily\LARGE{$course-name$}} der Fahrerausbildung der Fraport AG teilgenommen. -$if(course-content)$ - ### Inhalte: +\vspace{\fill} +\vspace{\fill} + +$if(course-content)$ +## Inhalte: {-} + + +%%%course-content%%% + - $course-content$ $endif$ +\vspace{\fill} +\vspace{\fill} + Mit Aushändigung der Teilnahmebescheinigung wird der erfolgreiche Abschluss des Kurses bestätigt. Dieses Zertifikat wurde maschinell erstellt. +\medskip Frankfurt am Main, $date$ - Fraport College +\vspace{\fill} +\vspace{\fill} +\vspace{\fill} +\vspace{\fill} +\vspace{\fill} + $else$ diff --git a/templates/letter/plain_article.latex b/templates/letter/plain_article.latex index 7d3bf4316..e95489125 100644 --- a/templates/letter/plain_article.latex +++ b/templates/letter/plain_article.latex @@ -57,8 +57,9 @@ $endif$ \usepackage{DejaVuSansMono} % better monofont \else % if luatex or xetex - \usepackage{fontspec} + \usepackage{fontspec} \setmonofont{DejaVu Sans Mono} + %\renewcommand{\familydefault}{\sfdefault} \fi $if(mathspec)$ @@ -96,6 +97,8 @@ $endif$ \providecommand{\tightlist}{% \setlength{\itemsep}{0pt}\setlength{\parskip}{0pt}} +\pagestyle{empty} + \begin{document}% $if(apc-ident)$ \begin{textblock}{200}(5,5)%hpos,vpos diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 7e9badc5e..8ced73ec8 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -942,11 +942,11 @@ fillDb = do , courseTerm = tk , courseSchool = avn , courseCapacity = capacity - , courseVisibleFrom = jtt TermDayStart 0 Nothing toMidnight - , courseVisibleTo = jtt TermDayEnd 0 Nothing beforeMidnight - , courseRegisterFrom = jtt TermDayStart 0 Nothing toMidnight - , courseRegisterTo = jtt TermDayLectureStart (-1) Nothing toMidnight - , courseDeregisterUntil = jtt TermDayLectureStart (-5) (Just Monday) toMidnight + , courseVisibleFrom = jtt TermDayStart 1 Nothing toMidnight + , courseVisibleTo = jtt TermDayEnd 10 Nothing beforeMidnight + , courseRegisterFrom = jtt TermDayLectureStart 0 Nothing toMidnight + , courseRegisterTo = jtt TermDayLectureStart 1 Nothing toMidnight + , courseDeregisterUntil = jtt TermDayLectureStart 5 (Just Monday) toMidnight , courseRegisterSecret = Nothing , courseMaterialFree = True } From 5f536864a5d89bed3884e34097982c57e6aef73b Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 6 Apr 2023 12:56:59 +0000 Subject: [PATCH 7/9] refactor(letter): change pdf download for course certificates and filename generation --- src/Handler/Tutorial/Users.hs | 50 ++++++++++++----------- src/Handler/Utils/Download.hs | 34 ++++++++++++++- src/Utils/Print.hs | 39 ++++++++---------- src/Utils/Print/CourseCertificate.hs | 24 +++++++---- src/Utils/Print/Letters.hs | 4 ++ src/Utils/Print/RenewQualification.hs | 6 +++ templates/letter/fraport_qualification.md | 4 ++ 7 files changed, 107 insertions(+), 54 deletions(-) diff --git a/src/Handler/Tutorial/Users.hs b/src/Handler/Tutorial/Users.hs index 2a3a12987..9ce0d8ce3 100644 --- a/src/Handler/Tutorial/Users.hs +++ b/src/Handler/Tutorial/Users.hs @@ -21,7 +21,7 @@ import qualified Data.CaseInsensitive as CI import qualified Data.Set as Set import qualified Data.Map as Map --- import qualified Data.ByteString.Lazy as LBS +import qualified Data.ByteString.Lazy as LBS -- import qualified Data.Time.Zones as TZ import Database.Esqueleto.Experimental ((:&)(..)) @@ -60,8 +60,7 @@ data TutorialUserActionData getTUsersR, postTUsersR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> Handler TypedContent getTUsersR = postTUsersR -postTUsersR tid ssh csh tutn = do - showSex <- getShowSex +postTUsersR tid ssh csh tutn = do (Entity tutid tut@Tutorial{..}, (participantRes, participantTable), qualifications) <- runDB $ do cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh tutEnt@(Entity tutid _) <- fetchTutorial tid ssh csh tutn @@ -71,8 +70,7 @@ postTUsersR tid ssh csh tutn = do dayExpiry = flip addGregorianDurationClip (utctDay now) . fromMonths <$> minDur colChoices = mconcat $ catMaybes [ pure $ dbSelect (applying _2) id (return . view (hasEntity . _entityKey)) - , pure $ colUserNameModalHdr MsgTableCourseMembers ForProfileDataR - , guardOn showSex colUserSex' + , pure $ colUserNameModalHdr MsgTableCourseMembers ForProfileDataR , pure colUserEmail , pure colUserMatriclenr , pure colUserQualifications @@ -122,7 +120,7 @@ postTUsersR tid ssh csh tutn = do return (tutEnt, table, qualifications) let courseQids = Set.fromList (entityKey <$> qualifications) - formResult participantRes $ \case + tcontent <- formResultMaybe participantRes $ \case (TutorialUserPrintQualificationData{..}, selectedUsers) | tuQualification `Set.member` courseQids -> do rcvr <- requireAuth @@ -132,13 +130,15 @@ postTUsersR tid ssh csh tutn = do [l] -> do encRcvr <- encrypt $ entityKey rcvr apcIdent <- letterApcIdent l encRcvr now + let fName = letterFileName l renderLetter rcvr l apcIdent >>= \case - Left err -> sendResponseStatus internalServerError500 $ "PDF generation failed: \n" <> err - Right pdf -> do -- void $ sendByteStringAsFile "demoPDF.pdf" (LBS.toStrict pdf) now - let typePDF :: ContentType - typePDF = "application/pdf" - sendResponse (typePDF, toContent pdf) - _ -> addMessageI Error MsgErrorUnknownFormAction + Left err -> sendResponseStatus internalServerError500 $ "PDF generation failed: \n" <> err + Right pdf -> Just <$> sendByteStringAsFile fName (LBS.toStrict pdf) now + -- sendResponseByteStringFile "demoPDF.pdf" (LBS.toStrict pdf) + -- let typePDF :: ContentType + -- typePDF = "application/pdf" + -- sendResponse (typePDF, toContent pdf) + _ -> addMessageI Error MsgErrorUnknownFormAction >> return Nothing (TutorialUserGrantQualificationData{..}, selectedUsers) | tuQualification `Set.member` courseQids -> do -- today <- localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime @@ -161,17 +161,19 @@ postTUsersR tid ssh csh tutn = do ] addMessageI Success $ MsgTutorialUsersDeregistered nrDel redirect $ CTutorialR tid ssh csh tutn TUsersR - _other -> - addMessageI Error MsgErrorUnknownFormAction + _other -> addMessageI Error MsgErrorUnknownFormAction >> return Nothing - tutors <- runDB $ E.select $ do - (tutor :& user) <- E.from $ E.table @Tutor `E.innerJoin` E.table @User - `E.on` (\(tutor :& user) -> tutor E.^. TutorUser E.==. user E.^. UserId) - E.where_ $ tutor E.^. TutorTutorial E.==. E.val tutid - return user + case tcontent of + Just content -> return content -- abort and return produced content + Nothing -> do + tutors <- runDB $ E.select $ do + (tutor :& user) <- E.from $ E.table @Tutor `E.innerJoin` E.table @User + `E.on` (\(tutor :& user) -> tutor E.^. TutorUser E.==. user E.^. UserId) + E.where_ $ tutor E.^. TutorTutorial E.==. E.val tutid + return user - let heading = prependCourseTitle tid ssh csh $ CI.original tutorialName - html <- siteLayoutMsg heading $ do - setTitleI heading - $(widgetFile "tutorial-participants") - return $ toTypedContent html + let heading = prependCourseTitle tid ssh csh $ CI.original tutorialName + html <- siteLayoutMsg heading $ do + setTitleI heading + $(widgetFile "tutorial-participants") + return $ toTypedContent html diff --git a/src/Handler/Utils/Download.hs b/src/Handler/Utils/Download.hs index c80957efc..3c3a0d862 100644 --- a/src/Handler/Utils/Download.hs +++ b/src/Handler/Utils/Download.hs @@ -4,7 +4,8 @@ module Handler.Utils.Download ( sendThisFile - , sendByteStringAsFile + , sendByteStringAsFile --, sendByteStringAsFileAndExit + , sendResponseByteStringFile , sendFileReference , serveOneFile , serveSomeFiles @@ -176,6 +177,37 @@ sendByteStringAsFile fileTitle content fileModified = | null content = Nothing | otherwise = Just $ yield content +-- THIS DOES NOT WORK: +-- sendByteStringAsFileAndExit :: ( YesodAuthPersist UniWorX +-- , AuthEntity UniWorX ~ User +-- , AuthId UniWorX ~ UserId +-- , YesodPersistRunner UniWorX +-- , MonadCrypto (HandlerFor UniWorX), MonadCryptoKey (HandlerFor UniWorX) ~ CryptoIDKey +-- ) => FilePath -> ByteString -> UTCTime -> HandlerFor UniWorX a +-- sendByteStringAsFileAndExit fileTitle content fileModified= do +-- void $ sendByteStringAsFile fileTitle content fileModified +-- sendResponse () + + +-- | like sendByteStringAsFile, but uses sendResponse instead of respondSourceDB, ensuring that +-- remaining handler code is bybassed +sendResponseByteStringFile :: -- ( YesodAuthPersist UniWorX + -- , AuthEntity UniWorX ~ User + -- , AuthId UniWorX ~ UserId + -- , MonadCrypto (HandlerFor UniWorX), MonadCryptoKey (HandlerFor UniWorX) ~ CryptoIDKey + -- ) => + FilePath -> ByteString -> HandlerFor UniWorX a +sendResponseByteStringFile fileTitle fileContent = do + -- ensureApprootUserGeneratedMaybe' Nothing + when (null fileContent) $ sendResponseStatus noContent204 () + let cType = simpleContentType (mimeLookup $ pack fileTitle) <> "; charset=utf-8" + content = (cType, toContent fileContent) + -- setCSPSandbox + setContentDisposition ContentInline $ Just $ takeFileName fileTitle -- just displays, but cannot save + -- setContentDisposition ContentAttachment $ Just $ takeFileName fileTitle -- saves file pnly, no display + -- setContentDisposition' . Just $ takeFileName fileTitle + sendResponse content + sendFileReference :: forall file a. ( HasFileReference file , BearerAuthSite UniWorX diff --git a/src/Utils/Print.hs b/src/Utils/Print.hs index e019e5557..201469586 100644 --- a/src/Utils/Print.hs +++ b/src/Utils/Print.hs @@ -9,14 +9,16 @@ module Utils.Print , sendEmailOrLetter -- directly print or sends by email , printLetter -- always send a letter , letterApcIdent -- create acknowledge string for APC + , letterFileName -- default filename , encryptPDF - , sanitizeCmdArg, validCmdArgument + , sanitizeCmdArg, sanitizeCmdArg', validCmdArgument -- , compileTemplate, makePDF , _Meta, addMeta , toMeta, mbMeta -- single values - , mkMeta, appMeta, applyMetas -- multiple values + , mkMeta, appMeta, applyMetas -- multiple values , LetterRenewQualificationF(..) - , LetterCourseCertificate(), makeCourseCertificates + -- , LetterCourseCertificate() + , makeCourseCertificates ) where -- import Import.NoModel @@ -185,22 +187,13 @@ printLetter' pji pdf = do , pjiCourse = printJobCourse , pjiQualification = printJobQualification , pjiLmsUser = printJobLmsUser + , pjiFileName = fName } = pji - recipient <- join <$> mapM get printJobRecipient - sender <- join <$> mapM get printJobSender - course <- join <$> mapM get printJobCourse - quali <- join <$> mapM get printJobQualification - let nameRecipient = abbrvName <$> recipient - nameSender = abbrvName <$> sender - nameCourse = CI.original . courseShorthand <$> course - nameQuali = CI.original . qualificationShorthand <$> quali - let jobFullName = text2asciiAlphaNum $ - T.replace " " "-" (T.intercalate "_" . catMaybes $ [Just printJobName, nameQuali, nameCourse, nameSender, nameRecipient]) - printJobFilename = T.unpack $ jobFullName <> ".pdf" + printJobFilename = T.unpack $ text2asciiAlphaNum fName <> ".pdf" -- printJobFile <- sinkFileDB True $ yield $ LBS.toStrict pdf -- for PrintJobFile :: FileContentReference use this code printJobFile = LBS.toStrict pdf printJobAcknowledged = Nothing - lprPDF jobFullName pdf >>= \case + lprPDF printJobFilename pdf >>= \case Left err -> do return $ Left err Right ok -> do @@ -223,7 +216,8 @@ sendEmailOrLetter :: (MDLetter l, MDMail l) => UserId -> l -> Handler Bool sendEmailOrLetter recipient letter = do (underling, receivers, undercopy) <- updateReceivers recipient -- TODO: check to avoid this almost circular dependency now <- liftIO getCurrentTime - let pjid = getPJId letter + let pjid = getPJId letter + fName = letterFileName letter mailSubject = getMailSubject letter -- these are only needed if sent by email, but we're lazy anyway undername = underling ^. _userDisplayName -- nameHtml' underling undermail = CI.original $ underling ^. _userEmail @@ -274,7 +268,7 @@ sendEmailOrLetter recipient letter = do setSubjectI mailSubject editNotifications <- mkEditNotifications svr addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/genericMailLetter.hamlet") - addPart (File { fileTitle = T.unpack $ pjiName pjid <> ".pdf" + addPart (File { fileTitle = fName , fileModified = now , fileContent = Just $ yield $ LBS.toStrict attachment } :: PureFile) @@ -304,6 +298,10 @@ readProcess' pc = do sanitizeCmdArg :: Text -> Text sanitizeCmdArg = T.filter (\c -> c /= '\'' && c /= '"' && c/= '\\' && not (isSeparator c)) + +sanitizeCmdArg' :: String -> String +sanitizeCmdArg' = filter (\c -> c /= '\'' && c /= '"' && c/= '\\' && not (isSeparator c)) + -- | Returns Nothing if ok, otherwise the first mismatching character -- Pin Password is used as a commandline argument in Utils.Print.encryptPDF and hence poses a security risk validCmdArgument :: Text -> Maybe Char @@ -348,8 +346,8 @@ encryptPDF pw bs = over _Left (decodeUtf8 . LBS.toStrict) . exit2either <$> read -- > lpr -P fradrive -H fravm017173.fra.fraport.de:515 -T printJobName - -- | Internal only, use `printLetter` instead -lprPDF :: (MonadHandler m, HasAppSettings (HandlerSite m)) => Text -> LBS.ByteString -> m (Either Text Text) -lprPDF jb bs = do +lprPDF :: (MonadHandler m, HasAppSettings (HandlerSite m)) => FilePath -> LBS.ByteString -> m (Either Text Text) +lprPDF (sanitizeCmdArg' -> jb) bs = do mbLprServerArg <- $cachedHereBinary ("lprServer"::Text) getLprServerArg case mbLprServerArg of Nothing -> return $ Right "Print command ignored due to setting 'mail-reroute-to' being set." @@ -361,8 +359,7 @@ lprPDF jb bs = do , "-" -- read from stdin ] jobname | null jb = [] - | otherwise = ["-J " <> jb'] - jb' = T.unpack $ sanitizeCmdArg jb + | otherwise = ["-J " <> jb] exit2either <$> readProcess' pc where getLprServerArg = do diff --git a/src/Utils/Print/CourseCertificate.hs b/src/Utils/Print/CourseCertificate.hs index 9f32946cb..c04d3f05c 100644 --- a/src/Utils/Print/CourseCertificate.hs +++ b/src/Utils/Print/CourseCertificate.hs @@ -19,8 +19,10 @@ import Handler.Utils.Profile data LetterCourseCertificate = LetterCourseCertificate { ccCourseId :: CourseId - , ccCourseName :: Text - -- , ccTutorialName :: Text + , ccCourseName :: Text + , ccCourseShorthand :: Text + , ccCourseSchool :: Text + , ccTutorialName :: Text , ccCourseContent :: Maybe [Text] , ccCourseBegin :: Maybe Day , ccCourseEnd :: Maybe Day @@ -64,16 +66,22 @@ instance MDLetter LetterCourseCertificate where , pjiCourse = Just ccCourseId , pjiQualification = Nothing , pjiLmsUser = Nothing + , pjiFileName = "cert_" <> ccCourseSchool <> "-" <> ccCourseShorthand <> "-" <> ccTutorialName } makeCourseCertificates :: Traversable t => Tutorial -> Maybe Lang -> t UserId -> DB (t LetterCourseCertificate) -makeCourseCertificates tut ccCourseLang participants = do - let ccCourseId = tut ^. _tutorialCourse - Course{courseName, courseDescription} <- get404 ccCourseId - let ccCourseName = CI.original courseName - ccCourseContent = html2textlines <$> courseDescription - (ccCourseBegin, ccCourseEnd) = occurrencesBounds $ tut ^. _tutorialTime +makeCourseCertificates Tutorial{ tutorialName = CI.original -> ccTutorialName + , tutorialCourse = ccCourseId + , tutorialTime = occurrences + } ccCourseLang participants = do + Course{ courseName = CI.original -> ccCourseName + , courseShorthand = CI.original -> ccCourseShorthand + , courseSchool = CI.original . unSchoolKey -> ccCourseSchool + , courseDescription = fmap html2textlines -> ccCourseContent + } <- get404 ccCourseId + let (ccCourseBegin, ccCourseEnd') = occurrencesBounds occurrences + ccCourseEnd = bool ccCourseEnd' Nothing $ ccCourseBegin == ccCourseEnd forM participants $ \uid -> do User{userDisplayName=ccParticipant, userCompanyDepartment, userCompanyPersonalNumber} <- get404 uid (ccFraNumber, ccFraDepartment, ccCompany) <- diff --git a/src/Utils/Print/Letters.hs b/src/Utils/Print/Letters.hs index 19b0549cd..2b4b94ac0 100644 --- a/src/Utils/Print/Letters.hs +++ b/src/Utils/Print/Letters.hs @@ -174,6 +174,7 @@ data PrintJobIdentification = PrintJobIdentification , pjiCourse :: Maybe CourseId , pjiQualification :: Maybe QualificationId , pjiLmsUser :: Maybe LmsIdent + , pjiFileName :: Text -- suggested filename, without suffix ".pdf" } deriving (Eq, Show) @@ -234,6 +235,9 @@ letterApcIdent l uuid now = do tnow <- formatTime' "%y%m%d-%H" now return $ mkApcIdent uuid (getLetterEnvelope l) (getLetterKind $ pure l) tnow (pjiApcAcknowledge $ getPJId l) +letterFileName :: (MDLetter l) => l -> FilePath +letterFileName = Text.unpack . (<> ".pdf") . text2asciiAlphaNum . pjiFileName . getPJId + addApcIdent :: Text -> P.Meta addApcIdent = P.Meta . toMeta "apc-ident" diff --git a/src/Utils/Print/RenewQualification.hs b/src/Utils/Print/RenewQualification.hs index 537a8d8a8..fd953c40a 100644 --- a/src/Utils/Print/RenewQualification.hs +++ b/src/Utils/Print/RenewQualification.hs @@ -86,4 +86,10 @@ instance MDLetter LetterRenewQualificationF where , pjiCourse = Nothing , pjiQualification = Just qualId , pjiLmsUser = Just lmsLogin + , pjiFileName = "renew_" <> CI.original (unSchoolKey qualSchool) <> "-" <> qualShort <> "_" <> qualHolderSN + -- let nameRecipient = abbrvName <$> recipient + -- nameSender = abbrvName <$> sender + -- nameCourse = CI.original . courseShorthand <$> course + -- nameQuali = CI.original . qualificationShorthand <$> quali + -- in .. = T.replace " " "-" (T.intercalate "_" . catMaybes $ [Just printJobName, nameQuali, nameCourse, nameSender, nameRecipient]) } \ No newline at end of file diff --git a/templates/letter/fraport_qualification.md b/templates/letter/fraport_qualification.md index 7402d9cd5..2ca22bfc5 100644 --- a/templates/letter/fraport_qualification.md +++ b/templates/letter/fraport_qualification.md @@ -29,7 +29,11 @@ $if(company)$ $endif$ hat $if(course-begin)$ +$if(course-end)$ von $course-begin$ bis $course-end$ +$else$ +am $course-begin$ +$endif$ $endif$ an der Veranstaltung \centerline{\sffamily\LARGE{$course-name$}} From 768f03f6727f54b7c7aa18ecef8bc67302ee27cd Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 6 Apr 2023 15:41:59 +0000 Subject: [PATCH 8/9] feat(letter): allow printing of multiple course certificates at once --- src/Handler/Tutorial/Users.hs | 29 ++++++------ src/Utils.hs | 11 +++++ src/Utils/Print.hs | 55 +++++++++++++++++------ src/Utils/Print/CourseCertificate.hs | 3 +- templates/letter/fraport_qualification.md | 4 +- 5 files changed, 72 insertions(+), 30 deletions(-) diff --git a/src/Handler/Tutorial/Users.hs b/src/Handler/Tutorial/Users.hs index 9ce0d8ce3..e384524d8 100644 --- a/src/Handler/Tutorial/Users.hs +++ b/src/Handler/Tutorial/Users.hs @@ -124,21 +124,22 @@ postTUsersR tid ssh csh tutn = do (TutorialUserPrintQualificationData{..}, selectedUsers) | tuQualification `Set.member` courseQids -> do rcvr <- requireAuth + encRcvr <- encrypt $ entityKey rcvr letters <- runDB $ makeCourseCertificates tut Nothing $ toList selectedUsers - now <- liftIO getCurrentTime - case letters of - [l] -> do - encRcvr <- encrypt $ entityKey rcvr - apcIdent <- letterApcIdent l encRcvr now - let fName = letterFileName l - renderLetter rcvr l apcIdent >>= \case - Left err -> sendResponseStatus internalServerError500 $ "PDF generation failed: \n" <> err - Right pdf -> Just <$> sendByteStringAsFile fName (LBS.toStrict pdf) now - -- sendResponseByteStringFile "demoPDF.pdf" (LBS.toStrict pdf) - -- let typePDF :: ContentType - -- typePDF = "application/pdf" - -- sendResponse (typePDF, toContent pdf) - _ -> addMessageI Error MsgErrorUnknownFormAction >> return Nothing + let mbAletter = anyone letters + case mbAletter of + Nothing -> addMessageI Error MsgErrorUnknownFormAction >> return Nothing -- TODO: better error message + Just aletter -> do + now <- liftIO getCurrentTime + apcIdent <- letterApcIdent aletter encRcvr now + let fName = letterFileName aletter + renderLetters rcvr letters apcIdent >>= \case + Left err -> sendResponseStatus internalServerError500 $ "PDF generation failed: \n" <> err + Right pdf -> Just <$> sendByteStringAsFile fName (LBS.toStrict pdf) now + -- sendResponseByteStringFile "demoPDF.pdf" (LBS.toStrict pdf) + -- let typePDF :: ContentType + -- typePDF = "application/pdf" + -- sendResponse (typePDF, toContent pdf) (TutorialUserGrantQualificationData{..}, selectedUsers) | tuQualification `Set.member` courseQids -> do -- today <- localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime diff --git a/src/Utils.hs b/src/Utils.hs index e6c518358..0bafb212b 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -845,6 +845,11 @@ toNothing = const Nothing toNothingS :: String -> Maybe b toNothingS = const Nothing +-- | change second of maybe pair to Nothing, if both are Just and equal +eq2nothing :: Eq a => (Maybe a, Maybe a) -> (Maybe a, Maybe a) +eq2nothing (mx@(Just x), Just y) | x==y = (mx, Nothing) +eq2nothing p = p + -- replaced by a more general formulation, see canonical -- null2nothing :: MonoFoldable a => Maybe a -> Maybe a -- null2nothing (Just x) | null x = Nothing @@ -1297,6 +1302,12 @@ maxLength :: ( Integral n -- ^ @maxLegth n xs = length xs <= n@ maxLength l = not . minLength (succ l) +-- anyone :: (Foldable t) => t a -> Maybe a +-- | return any single element from a foldable, if it is not null +anyone :: (Foldable t, Alternative f) => t a -> f a +anyone = Fold.foldr ((<|>).pure) empty + + ------------ -- Writer -- ------------ diff --git a/src/Utils/Print.hs b/src/Utils/Print.hs index 201469586..7bd9e2c5d 100644 --- a/src/Utils/Print.hs +++ b/src/Utils/Print.hs @@ -6,6 +6,7 @@ module Utils.Print ( renderLetter -- used for generating letter pdfs + , renderLetters , sendEmailOrLetter -- directly print or sends by email , printLetter -- always send a letter , letterApcIdent -- create acknowledge string for APC @@ -107,7 +108,7 @@ import Utils.Print.CourseCertificate -- | read and writes markdown, applying it as its own template to apply meta -mdTemplating :: Text -> P.Meta -> HandlerFor UniWorX (Either P.PandocError Text) +mdTemplating :: Text -> P.Meta -> HandlerFor UniWorX (Either P.PandocError P.Pandoc) mdTemplating template meta = runExceptT $ do let readerOpts = def { P.readerExtensions = P.pandocExtensions , P.readerStripComments = True @@ -117,21 +118,20 @@ mdTemplating template meta = runExceptT $ do let writerOpts = def { P.writerExtensions = P.pandocExtensions , P.writerTemplate = Just tmpl } - ExceptT . pure . P.runPure $ P.writeMarkdown writerOpts $ appMeta setIsDeFromLang - $ addMeta meta doc + ExceptT . pure . P.runPure $ do + md_txt <- P.writeMarkdown writerOpts $ appMeta setIsDeFromLang $ addMeta meta doc + P.readMarkdown readerOpts md_txt + -- | creates a PDF using a LaTeX template -pdfLaTeX :: LetterKind -> P.Meta -> Text -> HandlerFor UniWorX (Either P.PandocError LBS.ByteString) -pdfLaTeX lk meta md = do +pdfLaTeX :: LetterKind -> P.Pandoc -> HandlerFor UniWorX (Either P.PandocError LBS.ByteString) +pdfLaTeX lk doc = do e_tmpl <- $cachedHereBinary ("LetterKind:" <> tshow lk) (liftIO . P.runIO $ compileTemplate $ templateLatex lk) actRight e_tmpl $ \tmpl -> liftIO . P.runIO $ do - let readerOpts = def { P.readerExtensions = P.pandocExtensions } - writerOpts = def { P.writerExtensions = P.pandocExtensions - , P.writerTemplate = Just tmpl } - doc <- P.readMarkdown readerOpts md - makePDF writerOpts - $ appMeta setIsDeFromLang - $ addMeta meta doc + let writerOpts = def { P.writerExtensions = P.pandocExtensions + , P.writerTemplate = Just tmpl } + makePDF writerOpts $ appMeta setIsDeFromLang doc + renderLetter :: (MDLetter l) => Entity User -> l -> Text -> Handler (Either Text LBS.ByteString) @@ -151,9 +151,38 @@ renderLetter rcvrEnt@Entity{entityVal=rcvr} mdl apcIdent = do --, toMeta "rcvr-email" $ rcvr & userDisplayEmail -- note that some templates use "email" already otherwise ] e_md <- mdTemplating tmpl meta - result <- actRight e_md $ pdfLaTeX kind meta + result <- actRight e_md $ pdfLaTeX kind return $ over _Left P.renderError result +-- TODO: apcIdent does not make sense for multiple letters +renderLetters :: (MDLetter l, Foldable f) => Entity User -> f l -> Text -> Handler (Either Text LBS.ByteString) +renderLetters rcvrEnt@Entity{entityVal=rcvr} mdls apcIdent + | Just l <- anyone mdls = do + now <- liftIO getCurrentTime + formatter@DateTimeFormatter{ format } <- getDateTimeFormatterUser' rcvr + let lang = selectDeEn $ rcvr & userLanguages -- select either German or English only, default de; see Utils.Lang + kind = getLetterKind $ pure l + + templateCombine _ err@Left{} = pure err + templateCombine mdl (Right doc1) = + let tmpl = getTemplate mdl + meta = addApcIdent apcIdent + <> letterMeta mdl formatter lang rcvrEnt + <> mkMeta + [ -- toMeta "lang" lang -- receiver language is decided in MDLetter instance, since some letters have fixed languages + toMeta "date" $ format SelFormatDate now + , toMeta "rcvr-name" $ rcvr & userDisplayName + , toMeta "address" $ fromMaybe [rcvr & userDisplayName] $ getPostalAddress rcvr + --, toMeta "rcvr-email" $ rcvr & userDisplayEmail -- note that some templates use "email" already otherwise + ] + in mdTemplating tmpl meta >>= \case + err@Left{} -> pure err + Right doc2 -> pure $ Right $ doc1 <> doc2 + + doc <- foldrM templateCombine (Right mempty) mdls + result <- actRight doc $ pdfLaTeX kind + return $ over _Left P.renderError result + | otherwise = return $ Left "renderLetters received empty set of letters" --------------- diff --git a/src/Utils/Print/CourseCertificate.hs b/src/Utils/Print/CourseCertificate.hs index c04d3f05c..cbbe1f05d 100644 --- a/src/Utils/Print/CourseCertificate.hs +++ b/src/Utils/Print/CourseCertificate.hs @@ -80,8 +80,7 @@ makeCourseCertificates Tutorial{ tutorialName = CI.original -> ccTutorialName , courseSchool = CI.original . unSchoolKey -> ccCourseSchool , courseDescription = fmap html2textlines -> ccCourseContent } <- get404 ccCourseId - let (ccCourseBegin, ccCourseEnd') = occurrencesBounds occurrences - ccCourseEnd = bool ccCourseEnd' Nothing $ ccCourseBegin == ccCourseEnd + let (ccCourseBegin, ccCourseEnd) = eq2nothing $ occurrencesBounds occurrences forM participants $ \uid -> do User{userDisplayName=ccParticipant, userCompanyDepartment, userCompanyPersonalNumber} <- get404 uid (ccFraNumber, ccFraDepartment, ccCompany) <- diff --git a/templates/letter/fraport_qualification.md b/templates/letter/fraport_qualification.md index 2ca22bfc5..5f43711a5 100644 --- a/templates/letter/fraport_qualification.md +++ b/templates/letter/fraport_qualification.md @@ -79,4 +79,6 @@ $else$ **English version is not yet implemened.** TODO -$endif$ \ No newline at end of file +$endif$ + +\clearpage \ No newline at end of file From 97096727d6680973796698dc81e31dd068149da6 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 6 Apr 2023 16:09:41 +0000 Subject: [PATCH 9/9] chore(avs): add debug info for failing avsQueryStatus call on problem page --- src/Handler/Admin/Avs.hs | 1 - src/Handler/Utils/Avs.hs | 9 ++++++++- 2 files changed, 8 insertions(+), 2 deletions(-) diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index b8283650b..337f99d48 100644 --- a/src/Handler/Admin/Avs.hs +++ b/src/Handler/Admin/Avs.hs @@ -367,7 +367,6 @@ getProblemAvsSynchR = do let catchAllAvs' r = flip catch (\err -> addMessageModal Error (i18n MsgAvsCommunicationError) (Right (text2widget $ tshow (err :: SomeException))) >> redirect r) catchAllAvs = catchAllAvs' ProblemAvsSynchR -- == current route; use only in conditions that are not repeated upon reload; do not call redirect within catchAllAvs actions! (AvsLicenceDifferences{..}, apidStatus) <- catchAllAvs' AdminR retrieveDifferingLicencesStatus - -- TODO: for all ids, uery PersonStatus and create a Map from AvsId to a List of all valid Cards -- unknownLicenceOwners' <- whenNonEmpty avsLicenceDiffRevokeAll $ \neZeros -> diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index 6ca6c5700..f772b0a4e 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -241,7 +241,14 @@ retrieveDifferingLicences' getStatus = do [ AvsStatusPerson avsid $ Set.singleton $ mkAdpc (even $ avsPersonId avsid) AvsCardColorGelb | Entity _ UserAvs{userAvsPersonId = avsid} <- avsUsrs ] #else let statQry = avsLicenceDifferences2LicenceIds lDiff - lStat <- if getStatus && notNull statQry then throwLeftM $ avsQueryStatus $ AvsQueryStatus statQry else return $ AvsResponseStatus mempty -- avoid unnecessary avs calls + lStat <- if getStatus && notNull statQry + then -- throwLeftM $ avsQueryStatus $ AvsQueryStatus statQry -- don't throw up here, licence differences are too important! TODO: Warn in Problem-Handler + avsQueryStatus (AvsQueryStatus statQry) >>= \case + Left err -> do + addMessage Error $ toHtml $ "avsQueryStatus failed for " <> tshow (length statQry) <> " requests with: \n" <> tshow err <> "\nREQUEST:\n" <> tshow statQry + return $ AvsResponseStatus mempty + Right res -> return res + else return $ AvsResponseStatus mempty -- avoid unnecessary avs calls #endif return (lDiff, avsResponseStatusMap lStat)