From c9806302db3724d60ba114c2744fc7dd752fd3e6 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 20 Mar 2023 16:02:40 +0000 Subject: [PATCH] refactor(letter): pdf letter mechanics --- .../Handler/SendNotification/Qualification.hs | 3 +- src/Utils/Print.hs | 168 +++++------------- src/Utils/Print/Letters.hs | 45 +++-- src/Utils/Print/RenewQualification.hs | 33 ++-- .../mail/body/qualificationRenewal.hamlet | 2 +- templates/mail/genericMailLetter.hamlet | 4 +- 6 files changed, 88 insertions(+), 167 deletions(-) diff --git a/src/Jobs/Handler/SendNotification/Qualification.hs b/src/Jobs/Handler/SendNotification/Qualification.hs index a10f320bd..852bee308 100644 --- a/src/Jobs/Handler/SendNotification/Qualification.hs +++ b/src/Jobs/Handler/SendNotification/Qualification.hs @@ -78,7 +78,8 @@ dispatchNotificationQualificationRenewal nQualification jRecipient = do let letter = LetterRenewQualificationF { lmsLogin = lmsUserIdent , lmsPin = lmsUserPin - , qualHolder = userDisplayName + , qualHolderID = jRecipient + , qualHolderDN = userDisplayName , qualHolderSN = userSurname , qualExpiry = qualificationUserValidUntil , qualId = nQualification diff --git a/src/Utils/Print.hs b/src/Utils/Print.hs index ea2e4466b..fdb6dc7fc 100644 --- a/src/Utils/Print.hs +++ b/src/Utils/Print.hs @@ -5,8 +5,8 @@ {-# OPTIONS_GHC -fno-warn-unused-top-binds #-} module Utils.Print - ( pdfRenewal, sendLetter' -- only used for test-letters triggered in route PrintSendR - , sendEmailOrLetter + ( renderLetter -- used for generating letter pdfs + , sendEmailOrLetter -- directly print or sends by email , encryptPDF , sanitizeCmdArg, validCmdArgument -- , compileTemplate, makePDF @@ -100,7 +100,7 @@ import Utils.Print.RenewQualification -- } --- | read and writes markdown, applying it as its own template to apply meta +-- | read and writes markdown, applying it as its own template to apply meta mdTemplating :: Text -> P.Meta -> HandlerFor UniWorX (Either P.PandocError Text) mdTemplating template meta = runExceptT $ do let readerOpts = def { P.readerExtensions = P.pandocExtensions @@ -114,22 +114,10 @@ mdTemplating template meta = runExceptT $ do ExceptT . pure . P.runPure $ P.writeMarkdown writerOpts $ appMeta setIsDeFromLang $ addMeta meta doc ---pdfDIN5008 :: P.PandocMonad m => Text -> m LBS.ByteString -- for pandoc > 2.18 -pdfDIN5008' :: P.Meta -> Text -> P.PandocIO LBS.ByteString -pdfDIN5008' meta md = do - tmpl <- compileTemplate templateDIN5008 - 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 - --- | creates a PDF using the din5008 template -pdfDIN5008 :: P.Meta -> Text -> HandlerFor UniWorX (Either P.PandocError LBS.ByteString) -pdfDIN5008 meta md = do - e_tmpl <- $cachedHereBinary ("din5008"::Text) (liftIO . P.runIO $ compileTemplate templateDIN5008) +-- | creates a PDF using a LaTeX template +pdfLaTeX :: LetterKind -> P.Meta -> Text -> HandlerFor UniWorX (Either P.PandocError LBS.ByteString) +pdfLaTeX lk meta md = 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 @@ -140,86 +128,26 @@ pdfDIN5008 meta md = do $ addMeta meta doc - -------------------------- --- Specialized Letters -- -------------------------- - --- | like 'reTemplateLetter' but uses 'templateRenewal' and caches the result -mdRenewal' :: P.Meta -> HandlerFor UniWorX (Either P.PandocError Text) -mdRenewal' meta = do - let readerOpts = def { P.readerExtensions = P.pandocExtensions - , P.readerStripComments = True - } - e_doc <- $cachedHereBinary ("renewal-pandoc"::Text) (liftIO . P.runIO $ P.readMarkdown readerOpts templateRenewal) - e_tmpl <- $cachedHereBinary ("renewal-template"::Text) (liftIO . P.runIO $ compileTemplate templateRenewal) - case (e_doc, e_tmpl) of - (Left err, _) -> pure $ Left err - (_, Left err) -> pure $ Left err - (Right md_doc, Right md_tmpl) -> do - let writerOpts = def { P.writerExtensions = P.pandocExtensions - , P.writerTemplate = Just md_tmpl - } - liftIO . P.runIO $ P.writeMarkdown writerOpts $ appMeta setIsDeFromLang - $ addMeta meta md_doc - --- | like 'reTemplateLetter' but uses 'templateRenewal' and caches the result -mdRenewal :: P.Meta -> HandlerFor UniWorX (Either P.PandocError Text) -mdRenewal meta = runExceptT $ do - let readerOpts = def { P.readerExtensions = P.pandocExtensions - , P.readerStripComments = True - } - doc <- ExceptT $ $cachedHereBinary ("renewal-pandoc"::Text) (pure . P.runPure $ P.readMarkdown readerOpts templateRenewal) - tmpl <- ExceptT $ $cachedHereBinary ("renewal-template"::Text) (pure . P.runPure $ compileTemplate templateRenewal) - let writerOpts = def { P.writerExtensions = P.pandocExtensions - , P.writerTemplate = Just tmpl - } - ExceptT . pure . P.runPure $ P.writeMarkdown writerOpts $ appMeta setIsDeFromLang - $ addMeta meta doc - - --- | combines 'mdRenewal' and 'pdfDIN5008'; only user in PrintSendR Test Handler -pdfRenewal :: P.Meta -> HandlerFor UniWorX (Either Text LBS.ByteString) -pdfRenewal meta = do - e_txt <- mdRenewal' meta - --actRight e_txt (pdfDIN5008 . appMeta setIsDeFromLang . addMeta meta) -- try this - result <- actRight e_txt $ pdfDIN5008 meta - return $ over _Left P.renderError result - -{- --- | like pdfRenewal but without caching -pdfRenewal' :: P.Meta -> P.PandocIO LBS.ByteString -pdfRenewal' meta = do - doc <- reTemplateLetter' meta templateRenewal - pdfDIN5008' meta doc --} - - --- Generic Version -pdfLetter :: Text -> P.Meta -> Handler (Either Text LBS.ByteString) -pdfLetter md meta = do - e_txt <- mdTemplating md meta - result <- actRight e_txt $ pdfDIN5008 meta - return $ over _Left P.renderError result - - renderLetter :: (MDLetter l) => Entity User -> l -> Handler (Either Text LBS.ByteString) -renderLetter Entity{entityKey=uid, entityVal=rcvr} mdl = do +renderLetter rcvrEnt@Entity{entityKey=uid, entityVal=rcvr} mdl = do now <- liftIO getCurrentTime uuid :: CryptoUUIDUser <- encrypt uid - formatter@DateTimeFormatter{ format } <- getDateTimeFormatterUser' rcvr - let lang = selectDeEn $ rcvr & userLanguages -- select either German or English only, default de; see Utils.Lang - tmpl = getTemplate $ pure mdl + 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 meta = letterApcIdent uuid mdl - <> letterMeta mdl formatter lang - <> mkMeta + <> letterMeta mdl formatter lang rcvrEnt + <> mkMeta [ toMeta "lang" lang , toMeta "date" $ format SelFormatDate now - , toMeta "rcvr-name" $ rcvr & userDisplayName + , 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 ] - pdfLetter tmpl meta + e_md <- mdTemplating tmpl meta + result <- actRight e_md $ pdfLaTeX kind meta + return $ over _Left P.renderError result @@ -276,49 +204,31 @@ sendLetter'' _ = do -} sendEmailOrLetter :: (MDLetter 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 - let tmpl = getTemplate $ pure letter - pjid = getPJId letter - -- Below are only needed if sent by email - mailSubject = getMailSubject letter + let pjid = getPJId 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 now <- liftIO getCurrentTime - oks <- forM receivers $ \Entity{ entityKey = svr, entityVal = rcvrUsr } -> do - formatter@DateTimeFormatter{ format } <- getDateTimeFormatterUser' rcvrUsr - encRecipient :: CryptoUUIDUser <- encrypt svr + oks <- forM receivers $ \rcvrEnt@Entity{ entityKey = svr, entityVal = rcvrUsr } -> do let (preferPost, postal) = getPostalPreferenceAndAddress rcvrUsr - isSupervised = recipient /= svr - lang = selectDeEn $ rcvrUsr & userLanguages -- select either German or English only, default de; see Utils.Lang - mailBody = getMailBody letter formatter - lMeta = letterMeta letter formatter lang <> mkMeta ( - ( if isSupervised - then - [ toMeta "supervisor" (rcvrUsr & userDisplayName) - , toMeta "de-opening" ("Sehr geehrte Damen und Herren,"::Text) - , toMeta "en-opening" ("Dear Sir or Madam,"::Text) - ] - else [] - ) <> - [ toMeta "lang" lang - , toMeta "date" $ format SelFormatDate now - , toMeta "address" $ fromMaybe [rcvrUsr & userDisplayName] postal - ] - ) - - pdfLetter tmpl lMeta >>= \case - _ | preferPost, isNothing postal -> do -- neither email nor postal is known + -- mailBody = getMailBody letter formatter + renderLetter rcvrEnt letter >>= \case + _ | preferPost, isNothing postal -> do -- neither email nor postal is known + encRecipient :: CryptoUUIDUser <- encrypt svr 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 + Left err -> do -- pdf generation failed + encRecipient :: CryptoUUIDUser <- encrypt svr 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 (sendLetter pdf pjid{ pjiRecipient = Just svr}) >>= \case - Left err -> do + Left err -> do + encRecipient :: CryptoUUIDUser <- encrypt svr let msg = "Notification failed for " <> tshow encRecipient <> ". PDF printing failed. The print job could not be sent: " <> cropText err $logErrorS "LETTER" msg return False @@ -332,15 +242,19 @@ sendEmailOrLetter recipient letter = do Nothing -> return pdf Just passwd -> encryptPDF passwd pdf >>= \case Right encPdf -> return encPdf - Left err -> do + Left err -> do + encRecipient :: CryptoUUIDUser <- encrypt svr 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 - let supername = rcvrUsr ^. _userDisplayName -- nameHtml' rcvrUsr addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/genericMailLetter.hamlet") addPart (File { fileTitle = T.unpack $ pjiName pjid <> ".pdf" , fileModified = now @@ -419,9 +333,9 @@ encryptPDF pw bs = over _Left (decodeUtf8 . LBS.toStrict) . exit2either <$> read lprPDF :: (MonadHandler m, HasAppSettings (HandlerSite m)) => Text -> LBS.ByteString -> m (Either Text Text) lprPDF jb bs = do mbLprServerArg <- $cachedHereBinary ("lprServer"::Text) getLprServerArg - case mbLprServerArg of + case mbLprServerArg of Nothing -> return $ Right "Print command ignored due to setting 'mail-reroute-to' being set." - Just lprServerArg -> do + Just lprServerArg -> do let pc = setStdin (byteStringInput bs) $ proc "lpr" $ jobname ++ -- -J jobname -- a name for job identification at printing site @@ -434,10 +348,10 @@ lprPDF jb bs = do exit2either <$> readProcess' pc where getLprServerArg = do - rerouteMail <- getsYesod $ view _appMailRerouteTo - case rerouteMail of + rerouteMail <- getsYesod $ view _appMailRerouteTo + case rerouteMail of Just _ -> return Nothing - Nothing -> do + Nothing -> do LprConf{..} <- getsYesod $ view _appLprConf return . Just $ "-P " <> lprQueue <> "@" <> lprHost <> ":" <> show lprPort diff --git a/src/Utils/Print/Letters.hs b/src/Utils/Print/Letters.hs index ede769222..9c1a4fe6c 100644 --- a/src/Utils/Print/Letters.hs +++ b/src/Utils/Print/Letters.hs @@ -126,15 +126,15 @@ defWriterOpts t = def { P.writerExtensions = P.pandocExtensions, P.writerTemplat data LetterKind = Din5008 -- scrlttr2: Standard postal letter with address field, expects peprinted FraportLogo - | PinLetter -- Like Din5008, but for special paper with a protected pin field + | PinLetter -- Like Din5008, but for special paper with a protected pin field | Plain -- scrartcl: Empty, expects empty paper with no preprints | PlainLogo -- Like plain, but expects to be printed on paper with Logo -- | Logo -- Like plain, but prints Fraport Logo in the upper right corner deriving (Eq, Show) templateLatex :: LetterKind -> Text -templateLatex = - let +templateLatex = + let tDin5008 = decodeUtf8 $(Data.FileEmbed.embedFile "templates/letter/din5008.latex") tPinLetter = decodeUtf8 $(Data.FileEmbed.embedFile "templates/letter/din5008with_pin.latex") tPlain = decodeUtf8 $(Data.FileEmbed.embedFile "templates/letter/plain_article.latex") @@ -146,16 +146,12 @@ templateLatex = paperKind :: LetterKind -> Text paperKind Din5008 = "a4logo" -paperKind PinLetter = "a4pin" -paperKind Plain = "a4plain" +paperKind PinLetter = "a4pin" -- "a4pinp" +paperKind Plain = "a4plain" -- "a4emty" paperKind PlainLogo = "a4logo" --- | DEPRECATED TODO: remove -templateDIN5008 :: Text -templateDIN5008 = decodeUtf8 $(Data.FileEmbed.embedFile "templates/letter/din5008.latex") -templateRenewal :: Text -templateRenewal = decodeUtf8 $(Data.FileEmbed.embedFile "templates/letter/fraport_renewal.md") + @@ -176,15 +172,15 @@ data PrintJobIdentification = PrintJobIdentification -- | create an identifier for printing with apc; which must always be place in the same position for all letters, printed in white on white -- Note that all letters to the same UUID within 24h are collated in one envelope -mkApcIdent :: CryptoUUIDUser -> LetterKind -> Text -> P.Meta -mkApcIdent uuid lk apcAck = P.Meta $ toMeta "apc-ident" $ apcSep <> apcIdent <> apcSep - where +mkApcIdent :: CryptoUUIDUser -> Char -> LetterKind -> Text -> P.Meta +mkApcIdent uuid envelope lk apcAck = P.Meta $ toMeta "apc-ident" $ apcSep <> apcIdent <> apcSep + where apcSep = "___" - apcIdent = Text.intercalate apcSep - [ tshow uuid + apcIdent = Text.intercalate apcSep + [ tshow uuid <> Text.cons '-' (Text.singleton envelope) , paperKind lk , apcAck - ] + ] @@ -204,13 +200,14 @@ convertProto _ (IsMeta v) = v convertProto f (IsTime t) = P.toMetaValue $ f t -} -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 -> P.Meta - getTemplate :: Proxy l -> Text - getLetterKind :: Proxy l -> LetterKind - getPJId :: l -> PrintJobIdentification +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 + getLetterKind :: Proxy l -> LetterKind + getTemplate :: Proxy l -> Text letterApcIdent :: MDLetter l => CryptoUUIDUser -> l -> P.Meta -letterApcIdent uuid l = mkApcIdent uuid (getLetterKind $ pure l) (pjiApcAcknowledge $ getPJId l) +letterApcIdent uuid l = mkApcIdent uuid (getLetterEnvelope l) (getLetterKind $ pure l) (pjiApcAcknowledge $ getPJId l) diff --git a/src/Utils/Print/RenewQualification.hs b/src/Utils/Print/RenewQualification.hs index dcccf0e64..daa3bf107 100644 --- a/src/Utils/Print/RenewQualification.hs +++ b/src/Utils/Print/RenewQualification.hs @@ -10,9 +10,11 @@ import Import import Text.Hamlet -- import Data.Char (isSeparator) --- import qualified Data.Text as T +import qualified Data.Text as Text import qualified Data.CaseInsensitive as CI +import Data.FileEmbed (embedFile) + import Utils.Print.Letters import Handler.Utils.Widgets (nameHtml) -- , nameHtml') @@ -20,7 +22,8 @@ import Handler.Utils.Widgets (nameHtml) -- , nameHtml') data LetterRenewQualificationF = LetterRenewQualificationF { lmsLogin :: LmsIdent , lmsPin :: Text - , qualHolder :: UserDisplayName + , qualHolderID :: UserId + , qualHolderDN :: UserDisplayName , qualHolderSN :: UserSurname , qualExpiry :: Day , qualId :: QualificationId @@ -43,31 +46,37 @@ letterRenewalQualificationFData LetterRenewQualificationF{lmsLogin} = LetterRene lmsUrlLogin = lmsUrl <> "/?login=" <> lmsIdent lmsIdent = getLmsIdent lmsLogin -instance MDLetter LetterRenewQualificationF where - getTemplate _ = templateRenewal - getLetterKind _ = PinLetter - getMailSubject l = SomeMessage $ MsgMailSubjectQualificationRenewal $ qualShort l - -- getMailBody l = SomeMessage $ MsgMailBodyQualificationRenewal $ qualName l +instance MDLetter LetterRenewQualificationF where + getLetterKind _ = PinLetter + getLetterEnvelope l = maybe 'q' 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 = + letterMeta l@LetterRenewQualificationF{..} DateTimeFormatter{ format } _lang Entity{entityKey=rcvrId, entityVal=User{userDisplayName}} = let LetterRenewQualificationFData{..} = letterRenewalQualificationFData l - in mkMeta + isSupervised = rcvrId /= qualHolderID + in mkMeta $ + guardMonoid isSupervised + [ toMeta "supervisor" userDisplayName + , toMeta "de-opening" ("Sehr geehrte Damen und Herren,"::Text) + , toMeta "en-opening" ("Dear Sir or Madam,"::Text) + ] <> [ toMeta "login" lmsIdent , toMeta "pin" lmsPin - , toMeta "examinee" qualHolder + , toMeta "examinee" qualHolderDN , toMeta "expiry" (format SelFormatDate qualExpiry) , mbMeta "validduration" (show <$> qualDuration) , toMeta "url-text" lmsUrl , toMeta "url" lmsUrlLogin - ] + ] getPJId LetterRenewQualificationF{..} = PrintJobIdentification { pjiName = "Renewal" - , pjiApcAcknowledge = "lms" <> getLmsIdent lmsLogin + , pjiApcAcknowledge = "lms-" <> getLmsIdent lmsLogin , pjiRecipient = Nothing -- to be filled later , pjiSender = Nothing , pjiCourse = Nothing diff --git a/templates/mail/body/qualificationRenewal.hamlet b/templates/mail/body/qualificationRenewal.hamlet index 66a619e37..2f5d78619 100644 --- a/templates/mail/body/qualificationRenewal.hamlet +++ b/templates/mail/body/qualificationRenewal.hamlet @@ -14,7 +14,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later #{qualName}
_{SomeMessage MsgLmsUser} -
#{nameHtml qualHolder qualHolderSN} +
#{nameHtml qualHolderDN qualHolderSN}
_{SomeMessage MsgLmsQualificationValidUntil}
#{format SelFormatDate qualExpiry} diff --git a/templates/mail/genericMailLetter.hamlet b/templates/mail/genericMailLetter.hamlet index 434debd80..c400328ad 100644 --- a/templates/mail/genericMailLetter.hamlet +++ b/templates/mail/genericMailLetter.hamlet @@ -36,8 +36,8 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later

_{SomeMessage MsgMailSupervisedBody}

    - $forall svr <- receivers + $forall csupr <- receivers
  • - #{nameHtml' svr} + #{nameHtml' csupr} ^{ihamletSomeMessage editNotifications}