fraport/fradrive
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
{ lmsLogin = lmsUserIdent
, lmsPin = lmsUserPin
, qualHolder = userDisplayName
, qualHolderID = jRecipient
, qualHolderDN = userDisplayName
, qualHolderSN = userSurname
, qualExpiry = qualificationUserValidUntil
, qualId = nQualification

168
src/Utils/Print.hs
View File

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

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

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

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

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

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)}>
#{qualName}
<dt>_{SomeMessage MsgLmsUser}
<dd>#{nameHtml qualHolder qualHolderSN}
<dd>#{nameHtml qualHolderDN qualHolderSN}
<dt>_{SomeMessage MsgLmsQualificationValidUntil}
<dd>#{format SelFormatDate qualExpiry}

4
templates/mail/genericMailLetter.hamlet
View File

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