From cdf7f5c3b915509a1880493c2b28171fe165e6f5 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 5 May 2023 15:28:05 +0000 Subject: [PATCH 1/5] chore(letter): expiry letter phone and expiry date fixes --- src/Handler/Admin/Test.hs | 2 +- src/Handler/PrintCenter.hs | 9 ++--- .../Handler/SendNotification/Qualification.hs | 2 +- src/Utils/Print.hs | 33 +++++++++++++++---- src/Utils/Print/ExpireQualification.hs | 14 +++++--- src/Utils/Print/Letters.hs | 7 ++-- src/Utils/Print/RenewQualification.hs | 2 +- templates/letter/fraport_f_expiry.md | 17 +++++++--- templates/mail/qualificationExpired.hamlet | 5 +-- 9 files changed, 64 insertions(+), 27 deletions(-) diff --git a/src/Handler/Admin/Test.hs b/src/Handler/Admin/Test.hs index ca0d2aae8..2699c4f0e 100644 --- a/src/Handler/Admin/Test.hs +++ b/src/Handler/Admin/Test.hs @@ -319,7 +319,7 @@ getAdminTestPdfR = do , qualDuration = qual ^. _qualificationValidDuration } apcIdent <- letterApcIdent letter encRecipient now - renderLetter usr letter apcIdent >>= \case + renderLetterPDF usr letter apcIdent >>= \case Left err -> sendResponseStatus internalServerError500 $ "PDF generation failed: \n" <> err Right pdf -> do liftIO $ LBS.writeFile "/tmp/generated.pdf" pdf diff --git a/src/Handler/PrintCenter.hs b/src/Handler/PrintCenter.hs index c80c669a9..1efb0dd4d 100644 --- a/src/Handler/PrintCenter.hs +++ b/src/Handler/PrintCenter.hs @@ -46,7 +46,7 @@ data LRQF = LRQF , lrqfQuali :: Entity Qualification , lrqfIdent :: LmsIdent , lrqfPin :: Text - , lrqfExpiry :: Day + , lrqfExpiry :: Maybe Day } deriving (Eq, Generic) makeRenewalForm :: Maybe LRQF -> Form LRQF @@ -59,7 +59,7 @@ makeRenewalForm tmpl = identifyForm FIDLmsLetter . validateForm validateLetterRe <*> areq qualificationFieldEnt (fslI MsgQualificationName) (lrqfQuali <$> tmpl) <*> areq lmsField (fslI MsgTableLmsIdent) (lrqfIdent <$> tmpl) <*> areq textField (fslI MsgTableLmsPin) (lrqfPin <$> tmpl) - <*> areq dayField (fslI MsgLmsQualificationValidUntil) (lrqfExpiry <$> tmpl) + <*> aopt dayField (fslI MsgLmsQualificationValidUntil) (lrqfExpiry <$> tmpl) where lmsField = convertField LmsIdent getLmsIdent textField @@ -73,13 +73,14 @@ lrqf2letter LRQF{..} | lrqfLetter == "r" = do usr <- getUser lrqfUser rcvr <- mapM getUser lrqfSuper + now <- liftIO getCurrentTime let letter = LetterRenewQualificationF { lmsLogin = lrqfIdent , lmsPin = lrqfPin , qualHolderID = usr ^. _entityKey , qualHolderDN = usr ^. _userDisplayName , qualHolderSN = usr ^. _userSurname - , qualExpiry = lrqfExpiry + , qualExpiry = fromMaybe (utctDay now) lrqfExpiry , qualId = lrqfQuali ^. _entityKey , qualName = lrqfQuali ^. _qualificationName . _CI , qualShort = lrqfQuali ^. _qualificationShorthand . _CI @@ -305,7 +306,7 @@ postPrintSendR = do , lrqfQuali = qual , lrqfIdent = LmsIdent "stuvwxyz" , lrqfPin = "76543210" - , lrqfExpiry = succ nowaday + , lrqfExpiry = Just $ succ nowaday } def_lrqf = mkLetter <$> mbQual diff --git a/src/Jobs/Handler/SendNotification/Qualification.hs b/src/Jobs/Handler/SendNotification/Qualification.hs index 852bee308..32a3d942d 100644 --- a/src/Jobs/Handler/SendNotification/Qualification.hs +++ b/src/Jobs/Handler/SendNotification/Qualification.hs @@ -51,7 +51,7 @@ dispatchNotificationQualificationExpired nQualification dExpired jRecipient = us encRecipient :: CryptoUUIDUser <- liftHandler $ encrypt jRecipient let entRecipient = Entity jRecipient recipient qname = CI.original qualificationName - expiryDate <- formatTimeUser SelFormatDate dExpired $ Just entRecipient + expiryDate <- fmap Just $ formatTimeUser SelFormatDate dExpired $ Just entRecipient $logDebugS "LMS" $ "Notify " <> tshow encRecipient <> " about expired qualification " <> qname diff --git a/src/Utils/Print.hs b/src/Utils/Print.hs index 72e689947..5b00aa3bf 100644 --- a/src/Utils/Print.hs +++ b/src/Utils/Print.hs @@ -5,7 +5,7 @@ {-# OPTIONS_GHC -fno-warn-unused-top-binds #-} module Utils.Print - ( renderLetter -- used for generating letter pdfs + ( renderLetterPDF -- used for generating letter pdfs , renderLetters , sendEmailOrLetter -- directly print or sends by email , printLetter -- always send a letter @@ -145,8 +145,8 @@ pdfLaTeX lk doc = do makePDF writerOpts $ appMeta setIsDeFromLang doc -renderLetter :: (MDLetter l) => Entity User -> l -> Text -> Handler (Either Text LBS.ByteString) -renderLetter rcvrEnt@Entity{entityVal=rcvr} mdl apcIdent = do +renderLetterPDF :: (MDLetter l) => Entity User -> l -> Text -> Handler (Either Text LBS.ByteString) +renderLetterPDF rcvrEnt@Entity{entityVal=rcvr} mdl apcIdent = 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 @@ -165,6 +165,25 @@ renderLetter rcvrEnt@Entity{entityVal=rcvr} mdl apcIdent = do actRight e_md $ pdfLaTeX kind +-- renderLetterHtml :: (MDLetter l) => Entity User -> l -> Text -> Handler (Either Text Html) +-- renderLetterHtml rcvrEnt@Entity{entityVal=rcvr} mdl apcIdent = 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 mdl +-- 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 +-- ] +-- e_md <- mdTemplating tmpl meta +-- actRight e_md $ pdfLaTeX kind + -- 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 @@ -208,7 +227,7 @@ printLetter senderId (rcvr, letter) = do encRecipient :: CryptoUUIDUser <- encrypt rcvrId now <- liftIO getCurrentTime apcIdent <- letterApcIdent letter encRecipient now - pdf <- renderLetter rcvr letter apcIdent + pdf <- renderLetterPDF rcvr letter apcIdent let protoPji = getPJId letter pji = protoPji { pjiRecipient = Just rcvrId @@ -266,8 +285,8 @@ sendEmailOrLetter recipient letter = do encRecipient :: CryptoUUIDUser <- encrypt svr apcIdent <- letterApcIdent letter encRecipient now let (preferPost, postal) = getPostalPreferenceAndAddress rcvrUsr - -- mailBody = getMailBody letter formatter - renderLetter rcvrEnt letter apcIdent >>= \case + -- mailBody <- getMailBody letter formatter + renderLetterPDF rcvrEnt letter apcIdent >>= \case _ | preferPost, isNothing postal -> do -- neither email nor postal is known let msg = "Notification failed for " <> tshow encRecipient <> ", who has neither a known email nor postal address. Notification: " <> tshow pjid $logErrorS "LETTER" msg @@ -303,7 +322,7 @@ sendEmailOrLetter recipient letter = do formatter <- getDateTimeFormatterUser' rcvrUsr -- not too expensive, only calls getTimeLocale let isSupervised = recipient /= svr supername = rcvrUsr ^. _userDisplayName -- nameHtml' rcvrUsr - mailBody = getMailBody letter formatter + mailBody <- getMailBody letter formatter userMailTdirect svr $ do replaceMailHeader "Auto-Submitted" $ Just "auto-generated" setSubjectI mailSubject diff --git a/src/Utils/Print/ExpireQualification.hs b/src/Utils/Print/ExpireQualification.hs index c7f5e8167..d596cbc1d 100644 --- a/src/Utils/Print/ExpireQualification.hs +++ b/src/Utils/Print/ExpireQualification.hs @@ -24,7 +24,7 @@ data LetterExpireQualificationF = LetterExpireQualificationF , leqfHolderID :: UserId , leqfHolderDN :: UserDisplayName , leqfHolderSN :: UserSurname - , leqfExpiry :: Day + , leqfExpiry :: Maybe Day , leqfId :: QualificationId , leqfName :: Text , leqfShort :: Text @@ -34,9 +34,10 @@ data LetterExpireQualificationF = LetterExpireQualificationF -- TODO: use markdown to generate the Letter instance MDMail LetterExpireQualificationF where + attachPDFLetter _ = False getMailSubject l = SomeMessage $ MsgMailSubjectQualificationExpired $ leqfShort l - getMailBody LetterExpireQualificationF{..} DateTimeFormatter{ format } = - let expiryDate = format SelFormatDate leqfExpiry + getMailBody LetterExpireQualificationF{..} DateTimeFormatter{ format } = return $ + let expiryDate = format SelFormatDate <$> leqfExpiry userDisplayName = leqfHolderDN userSurname = leqfHolderSN qualificationName = leqfName @@ -46,6 +47,11 @@ instance MDMail LetterExpireQualificationF where ihamletSomeMessage _ _ _ = (mempty :: Html) -- TODO: use markdown for letter editNotifications = () -- TODO: use markdown for letter in $(ihamletFile "templates/mail/qualificationExpired.hamlet") + -- const $ const html + -- Html -> HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX) + -- foo _ _ html -> html + -- [shamlet|#Ansprache #{html}|] um Html umzuwandeln! + -- instance MDLetter LetterExpireQualificationF where encryptPDFfor _ = NoPassword @@ -63,7 +69,7 @@ instance MDLetter LetterExpireQualificationF where ] <> [ toMeta "lang" lang , toMeta "licenceholder" leqfHolderDN - , toMeta "expiry" (format SelFormatDate leqfExpiry) + , mbMeta "expiry" (format SelFormatDate <$> leqfExpiry) ] getPJId LetterExpireQualificationF{..} = diff --git a/src/Utils/Print/Letters.hs b/src/Utils/Print/Letters.hs index 22ad52518..83759315e 100644 --- a/src/Utils/Print/Letters.hs +++ b/src/Utils/Print/Letters.hs @@ -217,7 +217,7 @@ data EncryptPDFfor = NoPassword | PasswordSupervisor | PasswordUnderling class MDLetter l where 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 + -- NOTE: METAs "date", "rcvr-name", "address" are set automatically by renderLetterPDF for each receiver getPJId :: l -> PrintJobIdentification getLetterEnvelope :: l -> Char getLetterKind :: l -> LetterKind @@ -249,4 +249,7 @@ getApcIdent _ = Nothing 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 + getMailBody :: (MonadHandler m) => l -> DateTimeFormatter -> m (HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX)) -- only used if letter is sent by email as pdf attachment + -- | should the email also contain the letter as a PDF attachment? + attachPDFLetter :: l -> Bool + attachPDFLetter = const True diff --git a/src/Utils/Print/RenewQualification.hs b/src/Utils/Print/RenewQualification.hs index fc6a05038..a7900105c 100644 --- a/src/Utils/Print/RenewQualification.hs +++ b/src/Utils/Print/RenewQualification.hs @@ -48,7 +48,7 @@ letterRenewalQualificationFData LetterRenewQualificationF{lmsLogin} = LetterRene instance MDMail LetterRenewQualificationF where getMailSubject l = SomeMessage $ MsgMailSubjectQualificationRenewal $ qualShort l - getMailBody l@LetterRenewQualificationF{..} DateTimeFormatter{ format } = + getMailBody l@LetterRenewQualificationF{..} DateTimeFormatter{ format } = return $ let LetterRenewQualificationFData{..} = letterRenewalQualificationFData l in $(ihamletFile "templates/mail/body/qualificationRenewal.hamlet") diff --git a/templates/letter/fraport_f_expiry.md b/templates/letter/fraport_f_expiry.md index 8cb3768e5..ee8b76fe1 100644 --- a/templates/letter/fraport_f_expiry.md +++ b/templates/letter/fraport_f_expiry.md @@ -4,7 +4,7 @@ de-subject: 'Entzug "F" (Vorfeldführerschein)' en-subject: Revocation of apron driving license author: Fraport AG - Fahrerausbildung (AVN-AR) -phone: +49 69 690-28467 +phone: +49 69 690-30306 email: fahrerausbildung@fraport.de place: Frankfurt am Main return-address: @@ -22,7 +22,6 @@ hyperrefoptions: hidelinks ### Metadaten, welche automatisch ersetzt werden: date: 11.11.1111 -expiry: 00.00.0000 lang: de-de is-de: true # Emfpänger @@ -58,7 +57,11 @@ den Wissenstest im Rahmen des Recurrent Trainings Vorfeldführerschein nicht bes oder die Ablauffrist nicht eingehalten. -Die Qualifikation „Vorfeldführerschein“ ist somit nicht mehr gültig. +Die Qualifikation „Vorfeldführerschein“ ist somit +$if(expiry)$ + seit $expiry$ +$endif$ +nicht mehr gültig. $if(supervisor)$ @@ -98,8 +101,12 @@ did not pass the required knowledge test within the allotted time for the renewal of the apron driving licence. -The qualification „Vorfeldführerschein“ (apron driving lincence) is therefore invalid now. - +The qualification „Vorfeldführerschein“ (apron driving lincence) is therefore invalid +$if(expiry)$ + since $expiry$. +$else$ + now. +$endif$ $if(supervisor)$ $licenceholder$ diff --git a/templates/mail/qualificationExpired.hamlet b/templates/mail/qualificationExpired.hamlet index a8ba9c974..a7d84f549 100644 --- a/templates/mail/qualificationExpired.hamlet +++ b/templates/mail/qualificationExpired.hamlet @@ -29,8 +29,9 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later #{qualificationName}
_{SomeMessage MsgLmsUser}
#{nameHtml userDisplayName userSurname} -
_{SomeMessage MsgQualificationExpired} -
#{expiryDate} + $maybe expDate <- expiryDate +
_{SomeMessage MsgQualificationExpired} +
#{expDate} ^{ihamletSomeMessage editNotifications} From f617d067f3b410b42748d64780c4e8dee9b90c25 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 5 May 2023 15:43:09 +0000 Subject: [PATCH 2/5] chore(avscard): fix filtering leading zeroes --- src/Model/Types/Avs.hs | 6 +++--- templates/letter/generic_template.html | 29 ++++++++++++++++++++++++++ 2 files changed, 32 insertions(+), 3 deletions(-) create mode 100644 templates/letter/generic_template.html diff --git a/src/Model/Types/Avs.hs b/src/Model/Types/Avs.hs index a12980ed6..f1937c736 100644 --- a/src/Model/Types/Avs.hs +++ b/src/Model/Types/Avs.hs @@ -138,7 +138,7 @@ instance {-# OVERLAPS #-} Canonical (Maybe AvsInternalPersonalNo) where -- where x is an 8 digit AvsCardNo prefixed by zeros, see normalizeAvsCardNo -- and y is the 1 digit AvsVersionNo type AvsVersionNo = Text -- always 1 digit -newtype AvsCardNo = AvsCardNo { avsCardNo :: Text } -- always 8 digits +newtype AvsCardNo = AvsCardNo { avsCardNo :: Text } -- always 8 digits -- TODO: Create Smart Constructor deriving (Eq, Ord, Show, Generic) deriving newtype (NFData, PathPiece, Csv.ToField, Csv.FromField) -- No longer needed: @@ -162,7 +162,7 @@ data AvsFullCardNo = AvsFullCardNo { avsFullCardNo :: AvsCardNo, avsFullCardVers deriving (Eq, Ord, Generic, NFData) tshowAvsFullCardNo :: AvsFullCardNo -> Text -tshowAvsFullCardNo AvsFullCardNo{..} = avsCardNo avsFullCardNo <> Text.cons '.' avsFullCardVersion +tshowAvsFullCardNo AvsFullCardNo{..} = avsCardNo (canonical avsFullCardNo) <> Text.cons '.' avsFullCardVersion instance Show AvsFullCardNo where show = Text.unpack . tshowAvsFullCardNo @@ -170,7 +170,7 @@ instance Show AvsFullCardNo where readAvsFullCardNo :: Text -> Maybe AvsFullCardNo readAvsFullCardNo (Text.span Char.isDigit -> (c, Text.uncons -> Just ('.',v))) | not $ Text.null c, Just (Char.isDigit -> True, "") <- Text.uncons v - = Just $ AvsFullCardNo (AvsCardNo c) v + = Just $ AvsFullCardNo (AvsCardNo $ normalizeAvsCardNo c) v readAvsFullCardNo _ = Nothing instance PersistField AvsFullCardNo where diff --git a/templates/letter/generic_template.html b/templates/letter/generic_template.html new file mode 100644 index 000000000..f3183bebf --- /dev/null +++ b/templates/letter/generic_template.html @@ -0,0 +1,29 @@ + + + + + + + $for(author-meta)$ + $endfor$ $if(date-meta)$ + $endif$ $if(keywords)$ + $endif$ + $if(title-prefix)$$title-prefix$ \8211 $endif$$pagetitle$ + $for(css)$ + $endfor$ $if(math)$ $math$ $endif$ + + $for(header-includes)$ + $header-includes$ $endfor$ + + + $for(include-before)$ $include-before$ $endfor$ $if(title)$
+

$title$

$if(subtitle)$

$subtitle$

$endif$ $for(author)$

$author$

$endfor$ $if(date)$

$date$

$endif$ +
+ $endif$ $if(toc)$ + $endif$ $body$ $for(include-after)$ $include-after$ $endfor$ + + \ No newline at end of file From 539593fe2d17707c9f82ed6fc0c6f78ba0cab018 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 8 May 2023 14:42:29 +0000 Subject: [PATCH 3/5] chore(letter): html expiry letter working --- .../uniworx/categories/print/de-de-formal.msg | 3 +- messages/uniworx/categories/print/en-eu.msg | 3 +- src/Handler/PrintCenter.hs | 38 ++- src/Utils/Print.hs | 62 +++-- src/Utils/Print/ExpireQualification.hs | 7 +- src/Utils/Print/Letters.hs | 3 + templates/letter/fraport_f_expiry.md | 17 +- templates/letter/generic_template.html | 263 +++++++++++++++++- 8 files changed, 340 insertions(+), 56 deletions(-) diff --git a/messages/uniworx/categories/print/de-de-formal.msg b/messages/uniworx/categories/print/de-de-formal.msg index c5a134c12..88b38730a 100644 --- a/messages/uniworx/categories/print/de-de-formal.msg +++ b/messages/uniworx/categories/print/de-de-formal.msg @@ -21,4 +21,5 @@ PrintQualification: Qualifikation PrintPDF !ident-ok: PDF PrintManualRenewal: Vorfeldführerschein Renewal-Brief testweise versenden PrintLmsUser: E‑Learning Id -PrintJobs: Druckaufräge \ No newline at end of file +PrintJobs: Druckaufräge +PrintLetterType: Brieftypkürzel \ No newline at end of file diff --git a/messages/uniworx/categories/print/en-eu.msg b/messages/uniworx/categories/print/en-eu.msg index 770a23725..5cf800eb3 100644 --- a/messages/uniworx/categories/print/en-eu.msg +++ b/messages/uniworx/categories/print/en-eu.msg @@ -21,4 +21,5 @@ PrintQualification: Qualification PrintPDF: PDF PrintManualRenewal: Manual sending of an apron driver's licence renewal letter PrintLmsUser: E‑learning id -PrintJobs: Print jobs \ No newline at end of file +PrintJobs: Print jobs +PrintLetterType: Letter type shorthand \ No newline at end of file diff --git a/src/Handler/PrintCenter.hs b/src/Handler/PrintCenter.hs index 1efb0dd4d..41fa484d3 100644 --- a/src/Handler/PrintCenter.hs +++ b/src/Handler/PrintCenter.hs @@ -53,7 +53,7 @@ makeRenewalForm :: Maybe LRQF -> Form LRQF makeRenewalForm tmpl = identifyForm FIDLmsLetter . validateForm validateLetterRenewQualificationF $ \html -> do -- now_day <- utctDay <$> liftIO getCurrentTime flip (renderAForm FormStandard) html $ LRQF - <$> areq textField (fslI MsgLmsUser) (lrqfLetter <$> tmpl) + <$> areq textField (fslI MsgPrintLetterType) (lrqfLetter <$> tmpl) <*> areq (userField False Nothing) (fslI MsgLmsUser) (lrqfUser <$> tmpl) <*> aopt (userField False Nothing) (fslI MsgTableSupervisor) (lrqfSuper <$> tmpl) <*> areq qualificationFieldEnt (fslI MsgQualificationName) (lrqfQuali <$> tmpl) @@ -88,10 +88,11 @@ lrqf2letter LRQF{..} , qualDuration = lrqfQuali ^. _qualificationValidDuration } return (fromMaybe usr rcvr, SomeLetter letter) - | lrqfLetter == "e" = do + | lrqfLetter == "e" || lrqfLetter == "E" = do rcvr <- mapM getUser lrqfSuper usr <- getUser lrqfUser usrUuid <- encrypt $ entityKey usr + urender <- liftHandler getUrlRender let letter = LetterExpireQualificationF { leqfHolderUUID = usrUuid , leqfHolderID = usr ^. _entityKey @@ -102,6 +103,7 @@ lrqf2letter LRQF{..} , leqfName = lrqfQuali ^. _qualificationName . _CI , leqfShort = lrqfQuali ^. _qualificationShorthand . _CI , leqfSchool = lrqfQuali ^. _qualificationSchool + , leqfUrl = pure . urender $ ForProfileDataR usrUuid } return (fromMaybe usr rcvr, SomeLetter letter) | otherwise = error "Unknown Letter Type encountered. Use 'e' or 'r' only." @@ -311,18 +313,26 @@ postPrintSendR = do def_lrqf = mkLetter <$> mbQual ((sendResult, sendWidget), sendEnctype) <- runFormPost $ makeRenewalForm def_lrqf - let procFormSend lrqf = do - ok <- (runDB (lrqf2letter lrqf) >>= printLetter (Just uid)) >>= \case - Left err -> do - let msg = "PDF printing failed with error: " <> err - $logErrorS "LPR" msg - addMessage Error $ toHtml msg - pure False - Right (ok, fpath) -> do - let response = if null ok then mempty else " Response: " <> ok - addMessage Success $ toHtml $ "Druckauftrag angelegt: " <> pack fpath <> response - pure True - when ok $ redirect PrintCenterR + let procFormSend lrqf = case lrqfLetter lrqf of + "E" -> (runDB (lrqf2letter lrqf) >>= printHtml (Just uid)) >>= \case + Right html -> sendResponse $ toTypedContent html + Left err -> do + let msg = "PDF printing failed with error: " <> err + $logErrorS "LPR" msg + addMessage Error $ toHtml msg + pure () + _ -> do + ok <- (runDB (lrqf2letter lrqf) >>= printLetter (Just uid)) >>= \case + Left err -> do + let msg = "PDF printing failed with error: " <> err + $logErrorS "LPR" msg + addMessage Error $ toHtml msg + pure False + Right (ok, fpath) -> do + let response = if null ok then mempty else " Response: " <> ok + addMessage Success $ toHtml $ "Druckauftrag angelegt: " <> pack fpath <> response + pure True + when ok $ redirect PrintCenterR formResult sendResult procFormSend -- actionUrl <- fromMaybe AdminAvsR <$> getCurrentRoute siteLayoutMsg MsgPrintManualRenewal $ do diff --git a/src/Utils/Print.hs b/src/Utils/Print.hs index 5b00aa3bf..4682e2296 100644 --- a/src/Utils/Print.hs +++ b/src/Utils/Print.hs @@ -9,6 +9,7 @@ module Utils.Print , renderLetters , sendEmailOrLetter -- directly print or sends by email , printLetter -- always send a letter + , printHtml -- return letter as Html only , letterApcIdent -- create acknowledge string for APC , letterFileName -- default filename , encryptPDF @@ -165,24 +166,29 @@ renderLetterPDF rcvrEnt@Entity{entityVal=rcvr} mdl apcIdent = do actRight e_md $ pdfLaTeX kind --- renderLetterHtml :: (MDLetter l) => Entity User -> l -> Text -> Handler (Either Text Html) --- renderLetterHtml rcvrEnt@Entity{entityVal=rcvr} mdl apcIdent = 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 mdl --- 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 --- ] --- e_md <- mdTemplating tmpl meta --- actRight e_md $ pdfLaTeX kind +renderLetterHtml :: (MDLetter l) => Entity User -> l -> Text -> Handler (Either Text Html) +renderLetterHtml rcvrEnt@Entity{entityVal=rcvr} mdl apcIdent = 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 mdl + 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 + ] + e_md <- mdTemplating tmpl meta + actRight e_md $ \md -> pure . over _Left P.renderError . P.runPure $ do + html_tmpl <- compileTemplate $ templateHtml kind + -- html_tmpl <- ExceptT $ memcachedBy (Just . Right $ 6 * diffHour) ("LetterKind-Html: \n" <> tshow lk) (pure . over _Left P.renderError . P.runPure $ compileTemplate $ templateHtml lk) + let writerOpts = def { P.writerExtensions = P.pandocExtensions + , P.writerTemplate = Just html_tmpl } + P.writeHtml5 writerOpts $ appMeta setIsDeFromLang md -- TODO: apcIdent does not make sense for multiple letters renderLetters :: (MDLetter l, Foldable f) => Entity User -> f l -> Text -> Handler (Either Text LBS.ByteString) @@ -220,6 +226,15 @@ renderLetters rcvrEnt@Entity{entityVal=rcvr} mdls apcIdent -- PrintJobs -- --------------- +-- Only used in print-test-handler for PrintSendR +printHtml :: (MDLetter l) => Maybe UserId -> (Entity User, l) -> Handler (Either Text Html) +printHtml _senderId (rcvr, letter) = do + let rcvrId = rcvr ^. _entityKey + encRecipient :: CryptoUUIDUser <- encrypt rcvrId + now <- liftIO getCurrentTime + apcIdent <- letterApcIdent letter encRecipient now + renderLetterHtml rcvr letter apcIdent + -- Only used in print-test-handler for PrintSendR printLetter :: (MDLetter l) => Maybe UserId -> (Entity User, l) -> Handler (Either Text (Text, FilePath)) printLetter senderId (rcvr, letter) = do @@ -284,7 +299,16 @@ sendEmailOrLetter recipient letter = do oks <- forM receivers $ \rcvrEnt@Entity{ entityKey = svr, entityVal = rcvrUsr } -> do encRecipient :: CryptoUUIDUser <- encrypt svr apcIdent <- letterApcIdent letter encRecipient now - let (preferPost, postal) = getPostalPreferenceAndAddress rcvrUsr + -- case getPostalPreferenceAndAddress rcvrUsr of + -- (True, Nothing) -> do -- neither email nor postal is known + -- let msg = "Notification failed for " <> tshow encRecipient <> ", who has neither a known email nor postal address. Notification: " <> tshow pjid + -- $logErrorS "LETTER" msg + -- return False + -- + -- (False, _) -> do -- send Email + -- if attachPDFLetter + -- + let (preferPost, postal) = getPostalPreferenceAndAddress rcvrUsr -- mailBody <- getMailBody letter formatter renderLetterPDF rcvrEnt letter apcIdent >>= \case _ | preferPost, isNothing postal -> do -- neither email nor postal is known diff --git a/src/Utils/Print/ExpireQualification.hs b/src/Utils/Print/ExpireQualification.hs index d596cbc1d..fef6407e4 100644 --- a/src/Utils/Print/ExpireQualification.hs +++ b/src/Utils/Print/ExpireQualification.hs @@ -28,7 +28,8 @@ data LetterExpireQualificationF = LetterExpireQualificationF , leqfId :: QualificationId , leqfName :: Text , leqfShort :: Text - , leqfSchool :: SchoolId + , leqfSchool :: SchoolId + , leqfUrl :: Maybe Text } deriving (Eq, Show) @@ -53,6 +54,7 @@ instance MDMail LetterExpireQualificationF where -- [shamlet|#Ansprache #{html}|] um Html umzuwandeln! -- + instance MDLetter LetterExpireQualificationF where encryptPDFfor _ = NoPassword getLetterKind _ = Din5008 @@ -69,7 +71,8 @@ instance MDLetter LetterExpireQualificationF where ] <> [ toMeta "lang" lang , toMeta "licenceholder" leqfHolderDN - , mbMeta "expiry" (format SelFormatDate <$> leqfExpiry) + , mbMeta "expiry" (format SelFormatDate <$> leqfExpiry) + , mbMeta "licence-url" leqfUrl ] getPJId LetterExpireQualificationF{..} = diff --git a/src/Utils/Print/Letters.hs b/src/Utils/Print/Letters.hs index 83759315e..d3cd2ccb4 100644 --- a/src/Utils/Print/Letters.hs +++ b/src/Utils/Print/Letters.hs @@ -152,6 +152,9 @@ paperKind Plain = "a4wht" -- Ohne Logo paperKind Din5008 = "a4log" -- Mit Logo paperKind PlainLogo = "a4log" +templateHtml :: LetterKind -> Text +-- templateHtml Din5008 = decodeUtf8 $(Data.FileEmbed.embedFile "templates/letter/generic_template.html") +templateHtml _ = decodeUtf8 $(Data.FileEmbed.embedFile "templates/letter/generic_template.html") --------------- diff --git a/templates/letter/fraport_f_expiry.md b/templates/letter/fraport_f_expiry.md index ee8b76fe1..8df73e7ea 100644 --- a/templates/letter/fraport_f_expiry.md +++ b/templates/letter/fraport_f_expiry.md @@ -65,7 +65,12 @@ nicht mehr gültig. $if(supervisor)$ -$licenceholder$ darf +$if(licence-url)$ +[$licenceholder$]($licence-url$) +$else$ +$licenceholder$ +$endif$ +darf $else$ Sie dürfen $endif$ @@ -83,7 +88,7 @@ Telefon Email - : $email$ + : [$email$](mailto:$email$) $else$ Hierfür wenden Sie sich bitte an Ihren Arbeitgeber. @@ -109,7 +114,11 @@ $else$ $endif$ $if(supervisor)$ - $licenceholder$ +$if(licence-url)$ +[$licenceholder$]($licence-url$) +$else$ +$licenceholder$ +$endif$ $else$ You $endif$ @@ -128,7 +137,7 @@ Phone Email - : $email$ + : [$email$](mailto:$email$) $else$ Please contact your employer to book a course for you. diff --git a/templates/letter/generic_template.html b/templates/letter/generic_template.html index f3183bebf..4a752f3e8 100644 --- a/templates/letter/generic_template.html +++ b/templates/letter/generic_template.html @@ -4,26 +4,259 @@ - $for(author-meta)$ - $endfor$ $if(date-meta)$ - $endif$ $if(keywords)$ - $endif$ - $if(title-prefix)$$title-prefix$ \8211 $endif$$pagetitle$ + + $for(author-meta)$ $endfor$ + $if(date-meta)$ $endif$ + $if(keywords)$ + $endif$ + $if(title-prefix)$$title-prefix$ \8211 $endif$$pagetitle$ $for(css)$ - $endfor$ $if(math)$ $math$ $endif$ + $if(document-css)$ +html { +$if(mainfont)$ + font-family: $mainfont$; +$endif$ +$if(fontsize)$ + font-size: $fontsize$; +$endif$ +$if(linestretch)$ + line-height: $linestretch$; +$endif$ + color: $if(fontcolor)$$fontcolor$$else$#1a1a1a$endif$; + background-color: $if(backgroundcolor)$$backgroundcolor$$else$#fdfdfd$endif$; +} +body { + margin: 0 auto; + max-width: $if(maxwidth)$$maxwidth$$else$36em$endif$; + padding-left: $if(margin-left)$$margin-left$$else$50px$endif$; + padding-right: $if(margin-right)$$margin-right$$else$50px$endif$; + padding-top: $if(margin-top)$$margin-top$$else$50px$endif$; + padding-bottom: $if(margin-bottom)$$margin-bottom$$else$50px$endif$; + hyphens: auto; + overflow-wrap: break-word; + text-rendering: optimizeLegibility; + font-kerning: normal; +} +@media (max-width: 600px) { + body { + font-size: 0.9em; + padding: 12px; + } + h1 { + font-size: 1.8em; + } +} +@media print { + html { + background-color: $if(backgroundcolor)$$backgroundcolor$$else$white$endif$; + } + body { + background-color: transparent; + color: black; + font-size: 12pt; + } + p, h2, h3 { + orphans: 3; + widows: 3; + } + h2, h3, h4 { + page-break-after: avoid; + } +} +p { + margin: 1em 0; +} +a { + color: $if(linkcolor)$$linkcolor$$else$#1a1a1a$endif$; +} +a:visited { + color: $if(linkcolor)$$linkcolor$$else$#1a1a1a$endif$; +} +img { + max-width: 100%; +} +h1, h2, h3, h4, h5, h6 { + margin-top: 1.4em; +} +h5, h6 { + font-size: 1em; + font-style: italic; +} +h6 { + font-weight: normal; +} +ol, ul { + padding-left: 1.7em; + margin-top: 1em; +} +li > ol, li > ul { + margin-top: 0; +} +blockquote { + margin: 1em 0 1em 1.7em; + padding-left: 1em; + border-left: 2px solid #e6e6e6; + color: #606060; +} +$if(abstract)$ +div.abstract { + margin: 2em 2em 2em 2em; + text-align: left; + font-size: 85%; +} +div.abstract-title { + font-weight: bold; + text-align: center; + padding: 0; + margin-bottom: 0.5em; +} +$endif$ +code { + font-family: $if(monofont)$$monofont$$else$Menlo, Monaco, Consolas, 'Lucida Console', monospace$endif$; +$if(monobackgroundcolor)$ + background-color: $monobackgroundcolor$; + padding: .2em .4em; +$endif$ + font-size: 85%; + margin: 0; + hyphens: manual; +} +pre { + margin: 1em 0; +$if(monobackgroundcolor)$ + background-color: $monobackgroundcolor$; + padding: 1em; +$endif$ + overflow: auto; +} +pre code { + padding: 0; + overflow: visible; + overflow-wrap: normal; +} +.sourceCode { + background-color: transparent; + overflow: visible; +} +hr { + background-color: #1a1a1a; + border: none; + height: 1px; + margin: 1em 0; +} +table { + margin: 1em 0; + border-collapse: collapse; + width: 100%; + overflow-x: auto; + display: block; + font-variant-numeric: lining-nums tabular-nums; +} +table caption { + margin-bottom: 0.75em; +} +tbody { + margin-top: 0.5em; + border-top: 1px solid $if(fontcolor)$$fontcolor$$else$#1a1a1a$endif$; + border-bottom: 1px solid $if(fontcolor)$$fontcolor$$else$#1a1a1a$endif$; +} +th { + border-top: 1px solid $if(fontcolor)$$fontcolor$$else$#1a1a1a$endif$; + padding: 0.25em 0.5em 0.25em 0.5em; +} +td { + padding: 0.125em 0.5em 0.25em 0.5em; +} +header { + margin-bottom: 4em; + text-align: center; +} +#TOC li { + list-style: none; +} +#TOC ul { + padding-left: 1.3em; +} +#TOC > ul { + padding-left: 0; +} +#TOC a:not(:hover) { + text-decoration: none; +} +$endif$ +code{white-space: pre-wrap;} +span.smallcaps{font-variant: small-caps;} +div.columns{display: flex; gap: min(4vw, 1.5em);} +div.column{flex: auto; overflow-x: auto;} +div.hanging-indent{margin-left: 1.5em; text-indent: -1.5em;} +/* The extra [class] is a hack that increases specificity enough to + override a similar rule in reveal.js */ +ul.task-list[class]{list-style: none;} +ul.task-list li input[type="checkbox"] { + font-size: inherit; + width: 0.8em; + margin: 0 0.8em 0.2em -1.6em; + vertical-align: middle; +} +$if(quotes)$ +q { quotes: "“" "”" "‘" "’"; } +$endif$ +$if(displaymath-css)$ +.display.math{display: block; text-align: center; margin: 0.5rem auto;} +$endif$ +$if(highlighting-css)$ +/* CSS for syntax highlighting */ +$highlighting-css$ +$endif$ +$if(csl-css)$ +/* CSS for citations */ +div.csl-bib-body { } +div.csl-entry { + clear: both; +$if(csl-entry-spacing)$ + margin-bottom: $csl-entry-spacing$; +$endif$ +} +.hanging-indent div.csl-entry { + margin-left:2em; + text-indent:-2em; +} +div.csl-left-margin { + min-width:2em; + float:left; +} +div.csl-right-inline { + margin-left:2em; + padding-left:1em; +} +div.csl-indent { + margin-left: 2em; +} +$endif$ + + $for(css)$ $endfor$ + $if(math)$ $math$ $endif$ - $for(header-includes)$ - $header-includes$ $endfor$ + $for(header-includes)$ $header-includes$ $endfor$ - $for(include-before)$ $include-before$ $endfor$ $if(title)$
+ + $for(include-before)$ $include-before$ $endfor$ + $if(title)$

$title$

$if(subtitle)$

$subtitle$

$endif$ $for(author)$

$author$

$endfor$ $if(date)$

$date$

$endif$ -
- $endif$ $if(toc)$ - $endif$ $body$ $for(include-after)$ $include-after$ $endfor$ +
+ $endif$ + $if(toc)$ + $endif$ + + $if(is-de)$ $de-opening$ $else$ $en-opening$ $endif$ + $body$ + $if(is-de)$ $de-closing$ $else$ $en-closing$ $endif$ + + $for(include-after)$ $include-after$ $endfor$ + \ No newline at end of file From 4c5ce11b09f54926835ce10c084e4b3324ba0ddd Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 8 May 2023 17:19:46 +0000 Subject: [PATCH 4/5] refactor(qualifications): notification mechanic tied to button only for all invalid qualifications --- .../categories/qualification/de-de-formal.msg | 1 + .../categories/qualification/en-eu.msg | 1 + models/lms.model | 1 + src/Handler/LMS/Fake.hs | 1 + src/Handler/Qualification.hs | 6 +- src/Handler/Utils/Qualification.hs | 3 +- src/Handler/Utils/Users.hs | 2 + src/Jobs/Handler/LMS.hs | 35 ++++++++---- .../Handler/SendNotification/Qualification.hs | 57 ++++++++++++------- src/Jobs/Types.hs | 2 +- src/Utils/Print.hs | 5 +- test/Database/Fill.hs | 30 +++++----- 12 files changed, 92 insertions(+), 52 deletions(-) diff --git a/messages/uniworx/categories/qualification/de-de-formal.msg b/messages/uniworx/categories/qualification/de-de-formal.msg index eae8b0e69..71549a505 100644 --- a/messages/uniworx/categories/qualification/de-de-formal.msg +++ b/messages/uniworx/categories/qualification/de-de-formal.msg @@ -19,6 +19,7 @@ TableQualificationSapExport: SAP TableQualificationSapExportTooltip: Wird die Qualifikation an das SAP übermittelt? Betrifft nur Benutzer mit Fraport Personalnummer. LmsQualificationValidUntil: Gültig bis TableQualificationLastRefresh: Zuletzt erneuert +TableQualificationLastNotified: Letzte Benachrichtigung TableQualificationFirstHeld: Erstmalig TableQualificationBlockedDue: Entzogen TableQualificationBlockedTooltip: Wann wurde die Qualifikation vorübergehend außer Kraft gesetzt und warum wurde dies veranlasst? diff --git a/messages/uniworx/categories/qualification/en-eu.msg b/messages/uniworx/categories/qualification/en-eu.msg index 77a2dfbb5..674a34804 100644 --- a/messages/uniworx/categories/qualification/en-eu.msg +++ b/messages/uniworx/categories/qualification/en-eu.msg @@ -19,6 +19,7 @@ TableQualificationSapExport: Sent to SAP TableQualificationSapExportTooltip: Is this qualification transmitted to SAP? Only applies to qualification holder having a Fraport AG personnel number. LmsQualificationValidUntil: Valid until TableQualificationLastRefresh: Last renewed +TableQualificationLastNotified: Last notified TableQualificationFirstHeld: First held TableQualificationBlockedDue: Revoked TableQualificationBlockedTooltip: Why and when was this qualification temporarily suspended? diff --git a/models/lms.model b/models/lms.model index f96aca375..4f841f984 100644 --- a/models/lms.model +++ b/models/lms.model @@ -62,6 +62,7 @@ QualificationUser firstHeld Day -- first time the qualification was earned, should never change blockedDue QualificationBlocked Maybe -- isJust means that the qualification is currently revoked scheduleRenewal Bool default=true -- if false, no automatic renewal is scheduled and the qualification expires + lastNotified UTCTime default=now() -- last notficiation about being invalid -- temporärer Entzug vorsehen -- SAP Schnittstelle muss dann angepasst werden -- Begründungsfeld vorsehen UniqueQualificationUser qualification user diff --git a/src/Handler/LMS/Fake.hs b/src/Handler/LMS/Fake.hs index c3693e544..e0550e574 100644 --- a/src/Handler/LMS/Fake.hs +++ b/src/Handler/LMS/Fake.hs @@ -131,6 +131,7 @@ fakeQualificationUsers (Entity qid Qualification{qualificationRefreshWithin}) (u qualificationUserLastRefresh = qualificationUserFirstHeld qualificationUserBlockedDue = Nothing qualificationUserScheduleRenewal = True + qualificationUserLastNotified = now _ <- upsert QualificationUser{..} [ QualificationUserValidUntil =. qualificationUserValidUntil , QualificationUserLastRefresh =. qualificationUserLastRefresh diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index 2a5e2c0b8..52e3f43ee 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -339,7 +339,8 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do , single $ sortUserEmail queryUser , single $ sortUserMatriclenr queryUser , single ("valid-until" , SortColumn $ queryQualUser >>> (E.^. QualificationUserValidUntil)) - , single ("last-refresh" , SortColumn $ queryQualUser >>> (E.^. QualificationUserLastRefresh)) + , single ("last-refresh" , SortColumn $ queryQualUser >>> (E.^. QualificationUserLastRefresh)) + , single ("last-notified" , SortColumn $ queryQualUser >>> (E.^. QualificationUserLastNotified)) , single ("blocked-due" , SortColumnNeverNull $ queryQualUser >>> (E.^. QualificationUserBlockedDue)) -- , single ("lms-started" , SortColumn $ queryLmsUser >>> (E.?. LmsUserStarted)) -- , single ("lms-status" , SortColumn $ views (to queryLmsUser) (E.?. LmsUserStatus)) @@ -520,7 +521,8 @@ postQualificationR sid qsh = do -- $ \(preview $ resultLmsUser . _entityVal . _lmsUserStarted -> d) -> foldMap dateTimeCell d -- , sortable (Just "lms-status") (i18nCell MsgTableLmsStatus) $ \(preview $ resultLmsUser . _entityVal . _lmsUserStatus -> status) -> foldMap lmsStatusCell $ join status , sortable (Just "lms-status-plus")(i18nCell MsgTableLmsStatus & cellTooltipWgt Nothing (lmsStatusInfoCell isAdmin auditMonths)) - $ \(preview $ resultLmsUser . _entityVal -> lu) -> foldMap (lmsStatusPlusCell linkLmsUser) lu + $ \(preview $ resultLmsUser . _entityVal -> lu) -> foldMap (lmsStatusPlusCell linkLmsUser) lu + , sortable (Just "last-notified") (i18nCell MsgTableQualificationLastNotified) $ \( view $ resultQualUser . _entityVal . _qualificationUserLastNotified -> d) -> dateTimeCell d ] psValidator = def & defaultSorting [SortDescBy "last-refresh"] tbl <- mkQualificationTable isAdmin qent acts colChoices psValidator diff --git a/src/Handler/Utils/Qualification.hs b/src/Handler/Utils/Qualification.hs index c259e9867..6964073c5 100644 --- a/src/Handler/Utils/Qualification.hs +++ b/src/Handler/Utils/Qualification.hs @@ -14,7 +14,7 @@ import Database.Persist.Sql (updateWhereCount) import qualified Database.Esqueleto.Experimental as E -- might need TypeApplications Lang-Pragma import qualified Database.Esqueleto.Utils as E - +import Handler.Utils.DateTime (toMidnight) ------------------ -- SQL Snippets -- @@ -57,6 +57,7 @@ upsertQualificationUser qualificationUserQualification qualificationUserLastRef { qualificationUserFirstHeld = qualificationUserLastRefresh , qualificationUserBlockedDue = Nothing , qualificationUserScheduleRenewal = fromMaybe True mbScheduleRenewal + , qualificationUserLastNotified = toMidnight qualificationUserLastRefresh , .. } ( diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs index f583e65b1..087a543a7 100644 --- a/src/Handler/Utils/Users.hs +++ b/src/Handler/Utils/Users.hs @@ -827,6 +827,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do E.<&> (qualificationUser E.^. QualificationUserFirstHeld) E.<&> (qualificationUser E.^. QualificationUserBlockedDue) E.<&> (qualificationUser E.^. QualificationUserScheduleRenewal) + E.<&> (qualificationUser E.^. QualificationUserLastNotified) ) (\current excluded -> [ QualificationUserValidUntil E.=. combineWith current excluded E.greatest QualificationUserValidUntil @@ -834,6 +835,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do , QualificationUserFirstHeld E.=. combineWith current excluded E.least QualificationUserFirstHeld , QualificationUserBlockedDue E.=. combineWith current excluded E.greatest QualificationUserBlockedDue -- Tested: PostgreSQL GREATEST/LEAST ignores NULL values , QualificationUserScheduleRenewal E.=. combineWith current excluded E.greatest QualificationUserScheduleRenewal + , QualificationUserLastNotified E.=. combineWith current excluded E.greatest QualificationUserLastNotified ] ) deleteWhere [ QualificationUserUser ==. oldUserId ] diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index 074a3b866..eb92356ac 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -145,7 +145,7 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act -- end users that expired by doing nothing expiredLearners <- E.select $ do (quser :& luser) <- E.from $ - E.table @QualificationUser + E.table @QualificationUser `E.innerJoin` E.table @LmsUser `E.on` (\(quser :& luser) -> luser E.^. LmsUserUser E.==. quser E.^. QualificationUserUser @@ -158,13 +158,23 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act E.set luser [LmsUserStatus E.=. E.justVal (LmsExpired nowaday)] E.where_ $ (luser E.^. LmsUserId) `E.in_` E.valList (E.unValue <$> expiredLearners) $logInfoS "LMS" $ "Expired lms users " <> tshow nrExpired <> " for qualification " <> qshort - -- TODO: notify expired used - -- - -- forM_ expiredLearners $ \uid -> - -- queueDBJob JobSendNotification - -- { jRecipient = uid - -- , jNotification = NotificationQualificationExpired { nQualification = qid, nExpiry = nowaday } - -- } + + notifyInvalidDrivers <- E.select $ do + quser <- E.from $ E.table @QualificationUser + E.where_ $ E.not_ (validQualification nowaday quser) + E.&&. (( E.isNothing (quser E.^. QualificationUserBlockedDue) + E.&&. (E.day (quser E.^. QualificationUserLastNotified) E.<. quser E.^. QualificationUserValidUntil) + ) E.||. ( + E.isJust (quser E.^. QualificationUserBlockedDue) + E.&&. (E.day (quser E.^. QualificationUserLastNotified) E.<. ((quser E.^. QualificationUserBlockedDue) E.->. "day" :: E.SqlExpr (E.Value Day))) + )) + pure (quser E.^. QualificationUserUser) + + forM_ notifyInvalidDrivers $ \(E.Value uid) -> + queueDBJob JobSendNotification + { jRecipient = uid + , jNotification = NotificationQualificationExpired { nQualification = qid } + } -- purge outdated LmsUsers case qualificationAuditDuration quali of @@ -306,10 +316,11 @@ dispatchJobLmsUserlist qid = JobHandlerAtomic act } update luid [LmsUserStatus =. newStatus] void $ qualificationUserBlocking qid [lmsUserUser luser] $ Just $ mkQualificationBlocked QualificationBlockFailedELearning lmsMsgDay - queueDBJob JobSendNotification - { jRecipient = lmsUserUser luser - , jNotification = NotificationQualificationExpired { nQualification = qid, nExpiry = lmsMsgDay } - } + -- DEACTIVATED FOR NOW; UPON REACTIVATION: DELAY Sending to check for unblocking a few hours later! + -- queueDBJob JobSendNotification + -- { jRecipient = lmsUserUser luser + -- , jNotification = NotificationQualificationExpired { nQualification = qid } + -- } delete lulid $logInfoS "LmsUserlist" [st|Processed LMS Userlist with ${tshow (length results)} entries|] diff --git a/src/Jobs/Handler/SendNotification/Qualification.hs b/src/Jobs/Handler/SendNotification/Qualification.hs index 32a3d942d..6c438ded8 100644 --- a/src/Jobs/Handler/SendNotification/Qualification.hs +++ b/src/Jobs/Handler/SendNotification/Qualification.hs @@ -42,25 +42,44 @@ dispatchNotificationQualificationExpiry nQualification dExpiry jRecipient = user addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/qualificationExpiry.hamlet") -dispatchNotificationQualificationExpired :: QualificationId -> Day -> UserId -> Handler () -dispatchNotificationQualificationExpired nQualification dExpired jRecipient = userMailT jRecipient $ do - (recipient@User{..}, Qualification{..}) <- liftHandler . runDB $ (,) - <$> getJust jRecipient - <*> getJust nQualification +dispatchNotificationQualificationExpired :: QualificationId -> UserId -> Handler () +dispatchNotificationQualificationExpired nQualification jRecipient = do + encRecipient :: CryptoUUIDUser <- encrypt jRecipient + dbRes <- runDB $ (,,) + <$> get jRecipient + <*> get nQualification + <*> getBy (UniqueQualificationUser nQualification jRecipient) - encRecipient :: CryptoUUIDUser <- liftHandler $ encrypt jRecipient - let entRecipient = Entity jRecipient recipient - qname = CI.original qualificationName - expiryDate <- fmap Just $ formatTimeUser SelFormatDate dExpired $ Just entRecipient - - $logDebugS "LMS" $ "Notify " <> tshow encRecipient <> " about expired qualification " <> qname - - replaceMailHeader "Auto-Submitted" $ Just "auto-generated" - setSubjectI $ MsgMailSubjectQualificationExpired qname - - editNotifications <- mkEditNotifications jRecipient - - addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/qualificationExpired.hamlet") + case dbRes of + ( Just User{..}, Just Qualification{..}, Just (Entity quId QualificationUser{..})) -> do + urender <- getUrlRender + let expDay = maybe qualificationUserValidUntil (min qualificationUserValidUntil . qualificationBlockedDay) qualificationUserBlockedDue + qname = CI.original qualificationName + qshort = CI.original qualificationShorthand + letter = LetterExpireQualificationF + { leqfHolderUUID = encRecipient + , leqfHolderID = jRecipient + , leqfHolderDN = userDisplayName + , leqfHolderSN = userSurname + , leqfExpiry = Just expDay + , leqfId = nQualification + , leqfName = qname + , leqfShort = qshort + , leqfSchool = qualificationSchool + , leqfUrl = pure . urender $ ForProfileDataR encRecipient + } + if expDay > utctDay qualificationUserLastNotified + then do + notifyOk <- sendEmailOrLetter jRecipient letter + if notifyOk + then do + now <- liftIO getCurrentTime + runDB $ update quId [QualificationUserLastNotified =. now] + $logInfoS "LMS" $ "Notified " <> tshow encRecipient <> " about expired qualification " <> qname + else + $logErrorS "LMS" $ "Failed to notify " <> tshow encRecipient <> " about expired qualification " <> qname + else $logErrorS "LMS" $ "Suppressed repeated notification " <> tshow encRecipient <> " about expired qualification " <> qname + _ -> $logErrorS "LMS" $ "Failed to notify " <> tshow encRecipient <> " about expired qualification " <> tshow nQualification -- NOTE: Renewal expects that LmsUser already exists for recipient @@ -75,7 +94,7 @@ dispatchNotificationQualificationRenewal nQualification jRecipient = do case query of (Just User{userDisplayName, userSurname}, Just Qualification{..}, Just (Entity _ QualificationUser{..}), Just(Entity luid LmsUser{..})) -> do let qname = CI.original qualificationName - let letter = LetterRenewQualificationF + letter = LetterRenewQualificationF { lmsLogin = lmsUserIdent , lmsPin = lmsUserPin , qualHolderID = jRecipient diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index 410a2d960..85fbaded8 100644 --- a/src/Jobs/Types.hs +++ b/src/Jobs/Types.hs @@ -142,7 +142,7 @@ data Notification | NotificationSubmissionUserCreated { nUser :: UserId, nSubmission :: SubmissionId } | NotificationSubmissionUserDeleted { nUser :: UserId, nSheet :: SheetId, nSubmission :: SubmissionId } | NotificationQualificationExpiry { nQualification :: QualificationId, nExpiry :: Day } - | NotificationQualificationExpired { nQualification :: QualificationId, nExpiry :: Day } + | NotificationQualificationExpired { nQualification :: QualificationId } | NotificationQualificationRenewal { nQualification :: QualificationId } deriving (Eq, Ord, Show, Read, Generic) diff --git a/src/Utils/Print.hs b/src/Utils/Print.hs index 4682e2296..c2a8d198d 100644 --- a/src/Utils/Print.hs +++ b/src/Utils/Print.hs @@ -305,8 +305,9 @@ sendEmailOrLetter recipient letter = do -- $logErrorS "LETTER" msg -- return False -- - -- (False, _) -> do -- send Email - -- if attachPDFLetter + -- (False, _) | attachPDFLetter letter -> do -- send Email, with pdf attached + -- (False, _) -> -- send Email, render letter directly to html + -- (True , postal) -> -- send printed letter -- let (preferPost, postal) = getPostalPreferenceAndAddress rcvrUsr -- mailBody <- getMailBody letter formatter diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index d165ed9fc..c26576ef1 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -691,23 +691,23 @@ fillDb = do qid_f <- insert' $ Qualification avn "F" "Vorfeldführerschein" f_descr (Just 24) (Just 6) (Just $ CalendarDiffDays 0 60) True (Just AvsLicenceVorfeld) $ Just "F4466" qid_r <- insert' $ Qualification avn "R" "Rollfeldführerschein" r_descr (Just 12) (Just 6) (Just $ CalendarDiffDays 2 3) False (Just AvsLicenceRollfeld) $ Just "R2801" qid_l <- insert' $ Qualification ifi "L" "Lehrbefähigung" l_descr Nothing (Just 6) Nothing True Nothing Nothing - void . insert' $ QualificationUser jost qid_f (n_day 9) (n_day $ -1) (n_day $ -22) (Just $ QualificationBlocked (n_day $ -5) "LMS") True -- TODO: better dates! - void . insert' $ QualificationUser jost qid_r (n_day 99) (n_day $ -11) (n_day $ -222) Nothing True -- TODO: better dates! - void . insert' $ QualificationUser jost qid_l (n_day 999) (n_day $ -111) (n_day $ -2222) Nothing True -- TODO: better dates! - void . insert' $ QualificationUser gkleen qid_f (n_day $ -3) (n_day $ -4) (n_day $ -20) Nothing True - void . insert' $ QualificationUser maxMuster qid_f (n_day 0) (n_day $ -2) (n_day $ -8) Nothing False - void . insert' $ QualificationUser svaupel qid_f (n_day 1) (n_day $ -1) (n_day $ -2) Nothing True - void . insert' $ QualificationUser sbarth qid_f (n_day 400) (n_day $ -40) (n_day $ -1200) Nothing True - void . insert' $ QualificationUser tinaTester qid_f (n_day 3) (n_day $ -60) (n_day $ -250) (Just $ QualificationBlocked (n_day $ -7) "Some long explanation for the block!") False - void . insert' $ QualificationUser tinaTester qid_r (n_day 3) (n_day $ -60) (n_day $ -250) Nothing False - void . insert' $ QualificationUser gkleen qid_r (n_day $ -7) (n_day $ -2) (n_day $ -9) Nothing True - void . insert' $ QualificationUser maxMuster qid_r (n_day 1) (n_day $ -1) (n_day $ -2) Nothing False - -- void . insert' $ QualificationUser fhamann qid_r (n_day $ -3) (n_day $ -1) (n_day $ -2) Nothing True - void . insert' $ QualificationUser svaupel qid_l (n_day 1) (n_day $ -1) (n_day $ -2) Nothing True - void . insert' $ QualificationUser gkleen qid_l (n_day 9) (n_day $ -1) (n_day $ -7) Nothing True + void . insert' $ QualificationUser jost qid_f (n_day 9) (n_day $ -1) (n_day $ -22) (Just $ QualificationBlocked (n_day $ -5) "LMS") True (n_day' $ -9) -- TODO: better dates! + void . insert' $ QualificationUser jost qid_r (n_day 99) (n_day $ -11) (n_day $ -222) Nothing True (n_day' $ -9) -- TODO: better dates! + void . insert' $ QualificationUser jost qid_l (n_day 999) (n_day $ -111) (n_day $ -2222) Nothing True (n_day' $ -9) -- TODO: better dates! + void . insert' $ QualificationUser gkleen qid_f (n_day $ -3) (n_day $ -4) (n_day $ -20) Nothing True (n_day' $ -9) + void . insert' $ QualificationUser maxMuster qid_f (n_day 0) (n_day $ -2) (n_day $ -8) Nothing False (n_day' $ -1) + void . insert' $ QualificationUser svaupel qid_f (n_day 1) (n_day $ -1) (n_day $ -2) Nothing True (n_day' $ -9) + void . insert' $ QualificationUser sbarth qid_f (n_day 400) (n_day $ -40) (n_day $ -1200) Nothing True (n_day' $ -2) + void . insert' $ QualificationUser tinaTester qid_f (n_day 3) (n_day $ -60) (n_day $ -250) (Just $ QualificationBlocked (n_day $ -7) "Some long explanation for the block!") False (n_day' $ -9) + void . insert' $ QualificationUser tinaTester qid_r (n_day 3) (n_day $ -60) (n_day $ -250) Nothing False (n_day' $ -3) + void . insert' $ QualificationUser gkleen qid_r (n_day $ -7) (n_day $ -2) (n_day $ -9) Nothing True (n_day' $ -4) + void . insert' $ QualificationUser maxMuster qid_r (n_day 1) (n_day $ -1) (n_day $ -2) Nothing False (n_day' $ -6) + -- void . insert' $ QualificationUser fhamann qid_r (n_day $ -3) (n_day $ -1) (n_day $ -2) Nothing True (n_day' $ -9) + void . insert' $ QualificationUser svaupel qid_l (n_day 1) (n_day $ -1) (n_day $ -2) Nothing True (n_day' $ -7) + void . insert' $ QualificationUser gkleen qid_l (n_day 9) (n_day $ -1) (n_day $ -7) Nothing True (n_day' $ -8) qidfUsers <- Set.fromAscList . fmap (qualificationUserUser . entityVal) <$> selectList [QualificationUserQualification ==. qid_f] [Asc QualificationUserUser] - insertMany_ [QualificationUser uid qid_f (n_day 42) (n_day $ -42) (n_day $ -365) Nothing True | Entity uid _ <- take 200 matUsers, uid `Set.notMember` qidfUsers] + insertMany_ [QualificationUser uid qid_f (n_day 42) (n_day $ -42) (n_day $ -365) Nothing True (n_day' $ -11)| Entity uid _ <- take 200 matUsers, uid `Set.notMember` qidfUsers] void . insert' $ LmsResult qid_f (LmsIdent "hijklmn") (n_day (-1)) now void . insert' $ LmsResult qid_f (LmsIdent "opqgrs" ) (n_day (-2)) now void . insert' $ LmsResult qid_f (LmsIdent "pqgrst" ) (n_day (-3)) now From 785b97df76b08665771ae91a1eb01c3e2a05e40e Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 8 May 2023 17:58:37 +0000 Subject: [PATCH 5/5] chore(letter): enable direct letter mails --- src/Utils/Print.hs | 129 +++++++++++++++++++++++++-------------------- 1 file changed, 73 insertions(+), 56 deletions(-) diff --git a/src/Utils/Print.hs b/src/Utils/Print.hs index c2a8d198d..f1d3054de 100644 --- a/src/Utils/Print.hs +++ b/src/Utils/Print.hs @@ -288,7 +288,7 @@ printLetter'' _ = do -} sendEmailOrLetter :: (MDLetter l, MDMail l) => UserId -> l -> Handler Bool -sendEmailOrLetter recipient letter = do +sendEmailOrLetter recipient letter = do (underling, receivers, undercopy) <- updateReceivers recipient -- TODO: check to avoid this almost circular dependency now <- liftIO getCurrentTime let pjid = getPJId letter @@ -296,68 +296,85 @@ sendEmailOrLetter recipient letter = do 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 + mr <- getMessageRender + let mailSupervisorSubject = SomeMessage $ "[SUPERVISOR] " <> mr mailSubject oks <- forM receivers $ \rcvrEnt@Entity{ entityKey = svr, entityVal = rcvrUsr } -> do encRecipient :: CryptoUUIDUser <- encrypt svr apcIdent <- letterApcIdent letter encRecipient now - -- case getPostalPreferenceAndAddress rcvrUsr of - -- (True, Nothing) -> do -- neither email nor postal is known - -- let msg = "Notification failed for " <> tshow encRecipient <> ", who has neither a known email nor postal address. Notification: " <> tshow pjid - -- $logErrorS "LETTER" msg - -- return False - -- - -- (False, _) | attachPDFLetter letter -> do -- send Email, with pdf attached - -- (False, _) -> -- send Email, render letter directly to html - -- (True , postal) -> -- send printed letter - -- - let (preferPost, postal) = getPostalPreferenceAndAddress rcvrUsr - -- mailBody <- getMailBody letter formatter - renderLetterPDF rcvrEnt letter apcIdent >>= \case - _ | preferPost, isNothing postal -> do -- neither email nor postal is known + case getPostalPreferenceAndAddress rcvrUsr of + (True, Nothing) -> do -- neither email nor postal is known let msg = "Notification failed for " <> tshow encRecipient <> ", who has neither a known email nor postal address. Notification: " <> tshow pjid $logErrorS "LETTER" msg return False - Left err -> do -- pdf generation failed - let msg = "Notification failed for " <> tshow encRecipient <> ". PDF generation failed: "<> cropText err <> "For Notification: " <> tshow pjid - $logErrorS "LETTER" msg - return False - Right pdf | preferPost -> -- send printed letter - runDB (printLetter' pjid{pjiRecipient = Just svr, pjiApcAcknowledge = apcIdent} pdf) >>= \case - Left err -> do - let msg = "Notification failed for " <> tshow encRecipient <> ". PDF printing failed. The print job could not be sent: " <> cropText err + + (True , Just _postal) -> renderLetterPDF rcvrEnt letter apcIdent >>= \case -- send printed letter + Left err -> do -- pdf generation failed + let msg = "Notification failed for " <> tshow encRecipient <> ". PDF generation failed: "<> cropText err <> "For Notification: " <> tshow pjid $logErrorS "LETTER" msg - return False - Right (msg,_) - | null msg -> return True - | otherwise -> do - $logWarnS "LETTER" $ "PDF printing to send letter with lpr returned ExitSuccess and the following message: " <> msg - return True - Right pdf -> do -- send email - let pdfPass = case encryptPDFfor letter of - NoPassword -> Nothing - PasswordSupervisor -> rcvrUsr ^. _userPinPassword - PasswordUnderling -> underling ^. _userPinPassword - attachment <- case pdfPass of - Nothing -> return pdf - Just passwd -> encryptPDF passwd pdf >>= \case - Right encPdf -> return encPdf - Left err -> do - let msg = "Notification for " <> tshow encRecipient <> " has unencrypted attachment. Encrypting PDF failed: " <> cropText err - $logWarnS "LETTER" msg - return pdf - formatter <- getDateTimeFormatterUser' rcvrUsr -- not too expensive, only calls getTimeLocale - let isSupervised = recipient /= svr - supername = rcvrUsr ^. _userDisplayName -- nameHtml' rcvrUsr - mailBody <- getMailBody letter formatter - userMailTdirect svr $ do - replaceMailHeader "Auto-Submitted" $ Just "auto-generated" - setSubjectI mailSubject - editNotifications <- mkEditNotifications svr - addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/genericMailLetter.hamlet") - addPart (File { fileTitle = fName - , fileModified = now - , fileContent = Just $ yield $ LBS.toStrict attachment - } :: PureFile) - return True + return False + Right pdf -> runDB (printLetter' pjid{pjiRecipient = Just svr, pjiApcAcknowledge = apcIdent} pdf) >>= \case + Left err -> do + let msg = "Notification failed for " <> tshow encRecipient <> ". PDF printing failed. The print job could not be sent: " <> cropText err + $logErrorS "LETTER" msg + return False + Right (msg,_) + | null msg -> return True + | otherwise -> do + $logWarnS "LETTER" $ "PDF printing to send letter with lpr returned ExitSuccess and the following message: " <> msg + return True + + (False, _) | attachPDFLetter letter -> renderLetterPDF rcvrEnt letter apcIdent >>= \case -- send Email, with pdf attached + Left err -> do -- pdf generation failed + let msg = "Notification failed for " <> tshow encRecipient <> ". PDF attachment generation failed: "<> cropText err <> "For Notification: " <> tshow pjid + $logErrorS "LETTER" msg + return False + Right pdf -> do -- pdf generated, send as email attachment now + let pdfPass = case encryptPDFfor letter of + NoPassword -> Nothing + PasswordSupervisor -> rcvrUsr ^. _userPinPassword + PasswordUnderling -> underling ^. _userPinPassword + attachment <- case pdfPass of + Nothing -> return pdf + Just passwd -> encryptPDF passwd pdf >>= \case + Right encPdf -> return encPdf + Left err -> do + let msg = "Notification for " <> tshow encRecipient <> " has unencrypted attachment. Encrypting PDF failed: " <> cropText err + $logWarnS "LETTER" msg + return pdf + formatter <- getDateTimeFormatterUser' rcvrUsr -- not too expensive, only calls getTimeLocale + let isSupervised = recipient /= svr + supername = rcvrUsr ^. _userDisplayName -- nameHtml' rcvrUsr + mailBody <- getMailBody letter formatter + userMailTdirect svr $ do + replaceMailHeader "Auto-Submitted" $ Just "auto-generated" + setSubjectI mailSubject + editNotifications <- mkEditNotifications svr + addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/genericMailLetter.hamlet") + addPart (File { fileTitle = fName + , fileModified = now + , fileContent = Just $ yield $ LBS.toStrict attachment + } :: PureFile) + return True + + (False, _) -> renderLetterHtml rcvrEnt letter apcIdent >>= \case -- send Email, render letter directly to html + Left err -> do -- html generation failed + let msg = "Notification failed for " <> tshow encRecipient <> ". HTML generation failed: "<> cropText err <> "For Notification: " <> tshow pjid + $logErrorS "LETTER" msg + return False + Right html -> do -- html generated, send directly now + let isSupervised = recipient /= svr + -- subject = if isSupervised + -- then "[SUPERVISOR] " <> mailSubject + -- else mailSubject + subject = if isSupervised + then mailSupervisorSubject + else mailSubject + userMailTdirect svr $ do + replaceMailHeader "Auto-Submitted" $ Just "auto-generated" + setSubjectI subject + -- when isSupervised $ mapSubject ("[SUPERVISOR] " <>) + addHtmlMarkdownAlternatives html + return True return $ or oks