fraport/fradrive-old
Archived
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

refactor(letter): pdf letter mechanics

Browse Source
This commit is contained in:
Steffen Jost 2023-03-20 16:02:40 +00:00
parent 83ec6d4a90
commit c9806302db
6 changed files with 88 additions and 167 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
src/Jobs/Handler/SendNotification/Qualification.hs
View File

@ -78,7 +78,8 @@ dispatchNotificationQualificationRenewal nQualification jRecipient = do
let letter = LetterRenewQualificationF let letter = LetterRenewQualificationF
{ lmsLogin = lmsUserIdent { lmsLogin = lmsUserIdent
, lmsPin = lmsUserPin , lmsPin = lmsUserPin
, qualHolder = userDisplayName , qualHolderID = jRecipient
, qualHolderDN = userDisplayName
, qualHolderSN = userSurname , qualHolderSN = userSurname
, qualExpiry = qualificationUserValidUntil , qualExpiry = qualificationUserValidUntil
, qualId = nQualification , qualId = nQualification

138
src/Utils/Print.hs
View File

@ -5,8 +5,8 @@
{-# OPTIONS_GHC -fno-warn-unused-top-binds #-} {-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
module Utils.Print module Utils.Print
( pdfRenewal, sendLetter' -- only used for test-letters triggered in route PrintSendR ( renderLetter -- used for generating letter pdfs
, sendEmailOrLetter , sendEmailOrLetter -- directly print or sends by email
, encryptPDF , encryptPDF
, sanitizeCmdArg, validCmdArgument , sanitizeCmdArg, validCmdArgument
-- , compileTemplate, makePDF -- , compileTemplate, makePDF
@ -114,22 +114,10 @@ mdTemplating template meta = runExceptT $ do
ExceptT . pure . P.runPure $ P.writeMarkdown writerOpts $ appMeta setIsDeFromLang ExceptT . pure . P.runPure $ P.writeMarkdown writerOpts $ appMeta setIsDeFromLang
$ addMeta meta doc $ addMeta meta doc
--pdfDIN5008 :: P.PandocMonad m => Text -> m LBS.ByteString -- for pandoc > 2.18 -- | creates a PDF using a LaTeX template
pdfDIN5008' :: P.Meta -> Text -> P.PandocIO LBS.ByteString pdfLaTeX :: LetterKind -> P.Meta -> Text -> HandlerFor UniWorX (Either P.PandocError LBS.ByteString)
pdfDIN5008' meta md = do pdfLaTeX lk meta md = do
tmpl <- compileTemplate templateDIN5008 e_tmpl <- $cachedHereBinary ("LetterKind:" <> tshow lk) (liftIO . P.runIO $ compileTemplate $ templateLatex lk)
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)
actRight e_tmpl $ \tmpl -> liftIO . P.runIO $ do actRight e_tmpl $ \tmpl -> liftIO . P.runIO $ do
let readerOpts = def { P.readerExtensions = P.pandocExtensions } let readerOpts = def { P.readerExtensions = P.pandocExtensions }
writerOpts = def { P.writerExtensions = P.pandocExtensions writerOpts = def { P.writerExtensions = P.pandocExtensions
@ -140,78 +128,16 @@ pdfDIN5008 meta md = do
$ addMeta meta doc $ 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 :: (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 now <- liftIO getCurrentTime
uuid :: CryptoUUIDUser <- encrypt uid uuid :: CryptoUUIDUser <- encrypt uid
formatter@DateTimeFormatter{ format } <- getDateTimeFormatterUser' rcvr formatter@DateTimeFormatter{ format } <- getDateTimeFormatterUser' rcvr
let lang = selectDeEn $ rcvr & userLanguages -- select either German or English only, default de; see Utils.Lang let lang = selectDeEn $ rcvr & userLanguages -- select either German or English only, default de; see Utils.Lang
tmpl = getTemplate $ pure mdl kind = getLetterKind $ pure mdl
tmpl = getTemplate $ pure mdl
meta = letterApcIdent uuid mdl meta = letterApcIdent uuid mdl
<> letterMeta mdl formatter lang <> letterMeta mdl formatter lang rcvrEnt
<> mkMeta <> mkMeta
[ toMeta "lang" lang [ toMeta "lang" lang
, toMeta "date" $ format SelFormatDate now , toMeta "date" $ format SelFormatDate now
@ -219,7 +145,9 @@ renderLetter Entity{entityKey=uid, entityVal=rcvr} mdl = do
, toMeta "address" $ fromMaybe [rcvr & userDisplayName] $ getPostalAddress rcvr , toMeta "address" $ fromMaybe [rcvr & userDisplayName] $ getPostalAddress rcvr
--, toMeta "rcvr-email" $ rcvr & userDisplayEmail -- note that some templates use "email" already otherwise --, 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
@ -278,47 +206,29 @@ sendLetter'' _ = do
sendEmailOrLetter :: (MDLetter l) => UserId -> l -> Handler Bool 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 (underling, receivers, undercopy) <- updateReceivers recipient -- TODO: check to avoid this almost circular dependency
let tmpl = getTemplate $ pure letter let pjid = getPJId letter
pjid = getPJId letter mailSubject = getMailSubject letter -- these are only needed if sent by email, but we're lazy anyway
-- Below are only needed if sent by email
mailSubject = getMailSubject letter
undername = underling ^. _userDisplayName -- nameHtml' underling undername = underling ^. _userDisplayName -- nameHtml' underling
undermail = CI.original $ underling ^. _userEmail undermail = CI.original $ underling ^. _userEmail
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
oks <- forM receivers $ \Entity{ entityKey = svr, entityVal = rcvrUsr } -> do oks <- forM receivers $ \rcvrEnt@Entity{ entityKey = svr, entityVal = rcvrUsr } -> do
formatter@DateTimeFormatter{ format } <- getDateTimeFormatterUser' rcvrUsr
encRecipient :: CryptoUUIDUser <- encrypt svr
let (preferPost, postal) = getPostalPreferenceAndAddress rcvrUsr let (preferPost, postal) = getPostalPreferenceAndAddress rcvrUsr
isSupervised = recipient /= svr -- mailBody = getMailBody letter formatter
lang = selectDeEn $ rcvrUsr & userLanguages -- select either German or English only, default de; see Utils.Lang renderLetter rcvrEnt letter >>= \case
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 _ | 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 let msg = "Notification failed for " <> tshow encRecipient <> ", who has neither a known email nor postal address. Notification: " <> tshow pjid
$logErrorS "LETTER" msg $logErrorS "LETTER" msg
return False 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 let msg = "Notification failed for " <> tshow encRecipient <> ". PDF generation failed: "<> cropText err <> "For Notification: " <> tshow pjid
$logErrorS "LETTER" msg $logErrorS "LETTER" msg
return False return False
Right pdf | preferPost -> -- send printed letter Right pdf | preferPost -> -- send printed letter
runDB (sendLetter pdf pjid{ pjiRecipient = Just svr}) >>= \case 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 let msg = "Notification failed for " <> tshow encRecipient <> ". PDF printing failed. The print job could not be sent: " <> cropText err
$logErrorS "LETTER" msg $logErrorS "LETTER" msg
return False return False
@ -333,14 +243,18 @@ sendEmailOrLetter recipient letter = do
Just passwd -> encryptPDF passwd pdf >>= \case Just passwd -> encryptPDF passwd pdf >>= \case
Right encPdf -> return encPdf 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 let msg = "Notification for " <> tshow encRecipient <> " has unencrypted attachment. Encrypting PDF failed: " <> cropText err
$logWarnS "LETTER" msg $logWarnS "LETTER" msg
return pdf 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 userMailTdirect svr $ do
replaceMailHeader "Auto-Submitted" $ Just "auto-generated" replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
setSubjectI mailSubject setSubjectI mailSubject
editNotifications <- mkEditNotifications svr editNotifications <- mkEditNotifications svr
let supername = rcvrUsr ^. _userDisplayName -- nameHtml' rcvrUsr
addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/genericMailLetter.hamlet") addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/genericMailLetter.hamlet")
addPart (File { fileTitle = T.unpack $ pjiName pjid <> ".pdf" addPart (File { fileTitle = T.unpack $ pjiName pjid <> ".pdf"
, fileModified = now , fileModified = now

31
src/Utils/Print/Letters.hs
View File

@ -146,16 +146,12 @@ templateLatex =
paperKind :: LetterKind -> Text paperKind :: LetterKind -> Text
paperKind Din5008 = "a4logo" paperKind Din5008 = "a4logo"
paperKind PinLetter = "a4pin" paperKind PinLetter = "a4pin" -- "a4pinp"
paperKind Plain = "a4plain" paperKind Plain = "a4plain" -- "a4emty"
paperKind PlainLogo = "a4logo" 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,12 +172,12 @@ 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 -- | 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 -- Note that all letters to the same UUID within 24h are collated in one envelope
mkApcIdent :: CryptoUUIDUser -> LetterKind -> Text -> P.Meta mkApcIdent :: CryptoUUIDUser -> Char -> LetterKind -> Text -> P.Meta
mkApcIdent uuid lk apcAck = P.Meta $ toMeta "apc-ident" $ apcSep <> apcIdent <> apcSep mkApcIdent uuid envelope lk apcAck = P.Meta $ toMeta "apc-ident" $ apcSep <> apcIdent <> apcSep
where where
apcSep = "___" apcSep = "___"
apcIdent = Text.intercalate apcSep apcIdent = Text.intercalate apcSep
[ tshow uuid [ tshow uuid <> Text.cons '-' (Text.singleton envelope)
, paperKind lk , paperKind lk
, apcAck , apcAck
] ]
@ -205,12 +201,13 @@ convertProto f (IsTime t) = P.toMetaValue $ f t
-} -}
class MDLetter l where class MDLetter l where
getMailSubject :: l -> SomeMessage UniWorX -- only used if letter is sent by email as pdf attachment 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 :: l -> DateTimeFormatter -> HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX) -- only used if letter is sent by email as pdf attachment
letterMeta :: l -> DateTimeFormatter -> Lang -> P.Meta letterMeta :: l -> DateTimeFormatter -> Lang -> Entity User -> P.Meta
getTemplate :: Proxy l -> Text getPJId :: l -> PrintJobIdentification
getLetterKind :: Proxy l -> LetterKind getLetterEnvelope :: l -> Char
getPJId :: l -> PrintJobIdentification getLetterKind :: Proxy l -> LetterKind
getTemplate :: Proxy l -> Text
letterApcIdent :: MDLetter l => CryptoUUIDUser -> l -> P.Meta 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)

29
src/Utils/Print/RenewQualification.hs
View File

@ -10,9 +10,11 @@ import Import
import Text.Hamlet import Text.Hamlet
-- import Data.Char (isSeparator) -- import Data.Char (isSeparator)
-- import qualified Data.Text as T import qualified Data.Text as Text
import qualified Data.CaseInsensitive as CI import qualified Data.CaseInsensitive as CI
import Data.FileEmbed (embedFile)
import Utils.Print.Letters import Utils.Print.Letters
import Handler.Utils.Widgets (nameHtml) -- , nameHtml') import Handler.Utils.Widgets (nameHtml) -- , nameHtml')
@ -20,7 +22,8 @@ import Handler.Utils.Widgets (nameHtml) -- , nameHtml')
data LetterRenewQualificationF = LetterRenewQualificationF data LetterRenewQualificationF = LetterRenewQualificationF
{ lmsLogin :: LmsIdent { lmsLogin :: LmsIdent
, lmsPin :: Text , lmsPin :: Text
, qualHolder :: UserDisplayName , qualHolderID :: UserId
, qualHolderDN :: UserDisplayName
, qualHolderSN :: UserSurname , qualHolderSN :: UserSurname
, qualExpiry :: Day , qualExpiry :: Day
, qualId :: QualificationId , qualId :: QualificationId
@ -44,20 +47,26 @@ letterRenewalQualificationFData LetterRenewQualificationF{lmsLogin} = LetterRene
lmsIdent = getLmsIdent lmsLogin lmsIdent = getLmsIdent lmsLogin
instance MDLetter LetterRenewQualificationF where instance MDLetter LetterRenewQualificationF where
getTemplate _ = templateRenewal getLetterKind _ = PinLetter
getLetterKind _ = PinLetter getLetterEnvelope l = maybe 'q' fst $ Text.uncons (qualShort l)
getMailSubject l = SomeMessage $ MsgMailSubjectQualificationRenewal $ qualShort l getTemplate _ = decodeUtf8 $(Data.FileEmbed.embedFile "templates/letter/fraport_renewal.md")
-- getMailBody l = SomeMessage $ MsgMailBodyQualificationRenewal $ qualName l getMailSubject l = SomeMessage $ MsgMailSubjectQualificationRenewal $ qualShort l
getMailBody l@LetterRenewQualificationF{..} DateTimeFormatter{ format } = getMailBody l@LetterRenewQualificationF{..} DateTimeFormatter{ format } =
let LetterRenewQualificationFData{..} = letterRenewalQualificationFData l let LetterRenewQualificationFData{..} = letterRenewalQualificationFData l
in $(ihamletFile "templates/mail/body/qualificationRenewal.hamlet") 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 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 "login" lmsIdent
, toMeta "pin" lmsPin , toMeta "pin" lmsPin
, toMeta "examinee" qualHolder , toMeta "examinee" qualHolderDN
, toMeta "expiry" (format SelFormatDate qualExpiry) , toMeta "expiry" (format SelFormatDate qualExpiry)
, mbMeta "validduration" (show <$> qualDuration) , mbMeta "validduration" (show <$> qualDuration)
, toMeta "url-text" lmsUrl , toMeta "url-text" lmsUrl
@ -67,7 +76,7 @@ instance MDLetter LetterRenewQualificationF where
getPJId LetterRenewQualificationF{..} = getPJId LetterRenewQualificationF{..} =
PrintJobIdentification PrintJobIdentification
{ pjiName = "Renewal" { pjiName = "Renewal"
, pjiApcAcknowledge = "lms" <> getLmsIdent lmsLogin , pjiApcAcknowledge = "lms-" <> getLmsIdent lmsLogin
, pjiRecipient = Nothing -- to be filled later , pjiRecipient = Nothing -- to be filled later
, pjiSender = Nothing , pjiSender = Nothing
, pjiCourse = Nothing , pjiCourse = Nothing

2
templates/mail/body/qualificationRenewal.hamlet
View File

@ -14,7 +14,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
<a href=@{QualificationR qualSchool (CI.mk qualShort)}> <a href=@{QualificationR qualSchool (CI.mk qualShort)}>
#{qualName} #{qualName}
<dt>_{SomeMessage MsgLmsUser} <dt>_{SomeMessage MsgLmsUser}
<dd>#{nameHtml qualHolder qualHolderSN} <dd>#{nameHtml qualHolderDN qualHolderSN}
<dt>_{SomeMessage MsgLmsQualificationValidUntil} <dt>_{SomeMessage MsgLmsQualificationValidUntil}
<dd>#{format SelFormatDate qualExpiry} <dd>#{format SelFormatDate qualExpiry}

4
templates/mail/genericMailLetter.hamlet
View File

@ -36,8 +36,8 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
<p> <p>
_{SomeMessage MsgMailSupervisedBody} _{SomeMessage MsgMailSupervisedBody}
<ul> <ul>
$forall svr <- receivers $forall csupr <- receivers
<li> <li>
#{nameHtml' svr} #{nameHtml' csupr}
^{ihamletSomeMessage editNotifications} ^{ihamletSomeMessage editNotifications}