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

chore(letter): test printing with new ident strings working again

Browse Source
This commit is contained in:
Steffen Jost 2023-03-22 10:35:39 +00:00
parent 799f1fe184
commit 583a0a254d
10 changed files with 74 additions and 56 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
models/print.model
View File

@ -4,7 +4,7 @@
PrintJob
name Text
apcAcknowledge Text default='unknown'
apcIdent Text default='unknown'
filename FilePath
file ByteString -- stores plain pdf; otherwise use FileContentReference Maybe
created UTCTime
@ -15,5 +15,5 @@ PrintJob
qualification QualificationId Maybe OnDeleteCascade OnUpdateCascade
lmsUser LmsIdent Maybe OnDeleteCascade OnUpdateCascade -- allows tracking if recipient has been notified; must be unique
-- UniquePrintJobLmsUser lmsUser -- Note that in fact multiple print jobs per LMS user are possible!
-- UniquePrintJobApcAcknowledge apcAcknowledge -- TODO: not yet enforced, since LmsIdent is currently used
-- UniquePrintJobApcIdent apcIdent -- TODO: not yet enforced, since LmsIdent is currently used
deriving Generic

6
src/Handler/Admin/Test.hs
View File

@ -302,6 +302,7 @@ getAdminTestPdfR = do
qual <- fromMaybeM
(addMessage Error "Keine Qualifikation in der Datenbank zur Erzeugung eines Test-PDFs gefunden." >> redirect AdminTestR)
(runDB $ selectFirst [] [Asc QualificationAvsLicence, Asc QualificationShorthand])
encRecipient :: CryptoUUIDUser <- encrypt $ usr ^. _entityKey
now <- liftIO getCurrentTime
let nowaday = utctDay now
letter = LetterRenewQualificationF
@ -316,8 +317,9 @@ getAdminTestPdfR = do
, qualShort = qual ^. _qualificationShorthand . _CI
, qualSchool = qual ^. _qualificationSchool
, qualDuration = qual ^. _qualificationValidDuration
}
renderLetter usr letter >>= \case
}
apcIdent <- letterApcIdent letter encRecipient now
renderLetter usr letter apcIdent >>= \case
Left err -> sendResponseStatus internalServerError500 $ "PDF generation failed: \n" <> err
Right pdf -> do
liftIO $ LBS.writeFile "/tmp/generated.pdf" pdf

15
src/Handler/PrintCenter.hs
View File

@ -170,8 +170,8 @@ mkPJTable = do
, sortable (Just "filename") (i18nCell MsgPrintPDF) $ \r -> let k = r ^. resultPrintJob . _entityKey
t = r ^. resultPrintJob . _entityVal . _printJobFilename
in anchorCellM (PrintDownloadR <$> encrypt k) (toWgt t)
, sortable (Just "apcid") (i18nCell MsgPrintJobApcAcknowledge)$ \( view $ resultPrintJob . _entityVal . _printJobApcAcknowledge -> t) -> textCell t
, sortable (Just "name") (i18nCell MsgPrintJobName) $ \( view $ resultPrintJob . _entityVal . _printJobName -> n) -> textCell n
, sortable (Just "apcid") (i18nCell MsgPrintJobApcAcknowledge)$ \( view $ resultPrintJob . _entityVal . _printJobApcIdent -> t) -> textCell t
, sortable (Just "name") (i18nCell MsgPrintJobName) $ \( view $ resultPrintJob . _entityVal . _printJobName -> n) -> textCell n
, sortable (Just "recipient") (i18nCell MsgPrintRecipient) $ \(preview resultRecipient -> u) -> maybeCell u $ cellHasUserLink AdminUserR
, sortable (Just "sender") (i18nCell MsgPrintSender) $ \(preview resultSender -> u) -> maybeCell u $ cellHasUserLink AdminUserR
, sortable (Just "course") (i18nCell MsgPrintCourse) $ \(preview $ resultCourse . _entityVal -> c) -> maybeCell c courseCell
@ -183,7 +183,7 @@ mkPJTable = do
, single ("filename" , SortColumn $ queryPrintJob >>> (E.^. PrintJobFilename))
, single ("created" , SortColumn $ queryPrintJob >>> (E.^. PrintJobCreated))
, single ("acknowledged" , SortColumn $ queryPrintJob >>> (E.^. PrintJobAcknowledged))
, single ("apcid" , SortColumn $ queryPrintJob >>> (E.^. PrintJobApcAcknowledge))
, single ("apcid" , SortColumn $ queryPrintJob >>> (E.^. PrintJobApcIdent))
, single ("recipient" , sortUserNameBareM queryRecipient)
, single ("sender" , sortUserNameBareM querySender )
, single ("course" , SortColumn $ queryCourse >>> (E.?. CourseName))
@ -192,7 +192,7 @@ mkPJTable = do
]
dbtFilter = mconcat
[ single ("name" , FilterColumn . E.mkContainsFilter $ views (to queryPrintJob) (E.^. PrintJobName))
, single ("apcid" , FilterColumn . E.mkContainsFilter $ views (to queryPrintJob) (E.^. PrintJobApcAcknowledge))
, single ("apcid" , FilterColumn . E.mkContainsFilter $ views (to queryPrintJob) (E.^. PrintJobApcIdent))
, single ("filename" , FilterColumn . E.mkContainsFilter $ views (to queryPrintJob) (E.^. PrintJobFilename))
, single ("created" , FilterColumn . E.mkDayFilter $ views (to queryPrintJob) (E.^. PrintJobCreated))
--, single ("created" , FilterColumn . E.mkDayBetweenFilter $ views (to queryPrintJob) (E.^. PrintJobCreated))
@ -273,12 +273,13 @@ postPrintCenterR = do
getPrintSendR, postPrintSendR :: Handler Html
getPrintSendR = postPrintSendR
postPrintSendR = do
usr <- requireAuth -- to determine language and recipient for test
usr <- requireAuth -- to determine language and recipient for test
mbQual <- runDB $ selectFirst [] [Asc QualificationAvsLicence, Asc QualificationShorthand]
now <- liftIO getCurrentTime
let nowaday = utctDay now
uid = usr ^. _entityKey
mkLetter qual = LRQF
{ lrqfUser = Right $ usr ^. _entityKey
{ lrqfUser = Right uid
, lrqfSuper = Nothing
, lrqfQuali = qual
, lrqfIdent = LmsIdent "stuvwxyz"
@ -289,7 +290,7 @@ postPrintSendR = do
((sendResult, sendWidget), sendEnctype) <- runFormPost $ makeRenewalForm def_lrqf
let procFormSend lrqf = do
ok <- (runDB (lrqf2letter lrqf) >>= printLetter) >>= \case
ok <- (runDB (lrqf2letter lrqf) >>= printLetter (Just uid)) >>= \case
Left err -> do
let msg = "PDF printing failed with error: " <> err
$logErrorS "LPR" msg

4
src/Model/Types/Lms.hs
View File

@ -134,10 +134,10 @@ _lmsDay = iso LmsDay lms2day
-- | Format for day for LMS interface
lmsDayFormat :: String
lmsDayFormat = "%d-%m-%Y"
lmsDayFormat = "%d-%m-%Y" -- fixed in LMS interface desctiption, due defaultTimeLocale, should not use named entities like weekdays or month names
instance Csv.ToField LmsDay where
toField (LmsDay d) = Csv.toField $ Time.formatTime Time.defaultTimeLocale lmsDayFormat d -- TimeLocale should not matter; getTimeLocale requires MonadHandler
toField (LmsDay d) = Csv.toField $ Time.formatTime Time.defaultTimeLocale lmsDayFormat d -- TimeLocale should not matter since format string does not use names; getTimeLocale requires MonadHandler
instance Csv.FromField LmsDay where
-- parseField = fmap LmsDay . parseLmsDay <=< Csv.parseField

50
src/Utils/Print.hs
View File

@ -7,7 +7,8 @@
module Utils.Print
( renderLetter -- used for generating letter pdfs
, sendEmailOrLetter -- directly print or sends by email
, printLetter -- always send a letter
, printLetter -- always send a letter
, letterApcIdent -- create acknowledge string for APC
, encryptPDF
, sanitizeCmdArg, validCmdArgument
-- , compileTemplate, makePDF
@ -129,15 +130,14 @@ pdfLaTeX lk meta md = do
$ addMeta meta doc
renderLetter :: (MDLetter l) => Entity User -> l -> Handler (Either Text LBS.ByteString)
renderLetter rcvrEnt@Entity{entityKey=uid, entityVal=rcvr} mdl = do
now <- liftIO getCurrentTime
uuid :: CryptoUUIDUser <- encrypt uid
renderLetter :: (MDLetter l) => Entity User -> l -> Text -> Handler (Either Text LBS.ByteString)
renderLetter 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 $ pure mdl
tmpl = getTemplate $ pure mdl
meta = letterApcIdent uuid mdl
meta = addApcIdent apcIdent
<> letterMeta mdl formatter lang rcvrEnt
<> mkMeta
[ toMeta "lang" lang
@ -157,13 +157,19 @@ renderLetter rcvrEnt@Entity{entityKey=uid, entityVal=rcvr} mdl = do
---------------
-- Only used in print-test-handler for PrintSendR
printLetter :: (MDLetter l) => (Entity User, l) -> Handler (Either Text (Text, FilePath))
printLetter (rcvr, letter) = do
pdf <- renderLetter rcvr letter
printLetter :: (MDLetter l) => Maybe UserId -> (Entity User, l) -> Handler (Either Text (Text, FilePath))
printLetter senderId (rcvr, letter) = do
let rcvrId = rcvr ^. _entityKey
encRecipient :: CryptoUUIDUser <- encrypt rcvrId
now <- liftIO getCurrentTime
apcIdent <- letterApcIdent letter encRecipient now
pdf <- renderLetter rcvr letter apcIdent
let protoPji = getPJId letter
pji = protoPji
{ pjiRecipient = Just $ entityKey rcvr
{ pjiRecipient = Just rcvrId
, pjiSender = senderId
, pjiName = "TEST_" <> pjiName protoPji
, pjiApcAcknowledge = apcIdent
}
actRight pdf $ runDB . printLetter' pji
@ -171,7 +177,7 @@ printLetter' :: PrintJobIdentification -> LBS.ByteString -> DB (Either Text (Tex
printLetter' pji pdf = do
let PrintJobIdentification
{ pjiName = printJobName
, pjiApcAcknowledge = printJobApcAcknowledge
, pjiApcAcknowledge = printJobApcIdent
, pjiRecipient = printJobRecipient
, pjiSender = printJobSender
, pjiCourse = printJobCourse
@ -214,29 +220,28 @@ printLetter'' _ = do
sendEmailOrLetter :: (MDLetter l) => UserId -> l -> Handler Bool
sendEmailOrLetter recipient letter = do
(underling, receivers, undercopy) <- updateReceivers recipient -- TODO: check to avoid this almost circular dependency
now <- liftIO getCurrentTime
let pjid = getPJId letter
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 $ \rcvrEnt@Entity{ entityKey = svr, entityVal = rcvrUsr } -> do
let (preferPost, postal) = getPostalPreferenceAndAddress rcvrUsr
encRecipient :: CryptoUUIDUser <- encrypt svr
apcIdent <- letterApcIdent letter encRecipient now
let (preferPost, postal) = getPostalPreferenceAndAddress rcvrUsr
-- mailBody = getMailBody letter formatter
renderLetter rcvrEnt letter >>= \case
_ | preferPost, isNothing postal -> do -- neither email nor postal is known
encRecipient :: CryptoUUIDUser <- encrypt svr
renderLetter 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
return False
Left err -> do -- pdf generation failed
encRecipient :: CryptoUUIDUser <- encrypt svr
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} pdf) >>= \case
Left err -> do
encRecipient :: CryptoUUIDUser <- encrypt svr
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
@ -250,8 +255,7 @@ sendEmailOrLetter recipient letter = do
Nothing -> return pdf
Just passwd -> encryptPDF passwd pdf >>= \case
Right encPdf -> return encPdf
Left err -> do
encRecipient :: CryptoUUIDUser <- encrypt svr
Left err -> do
let msg = "Notification for " <> tshow encRecipient <> " has unencrypted attachment. Encrypting PDF failed: " <> cropText err
$logWarnS "LETTER" msg
return pdf

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

@ -7,15 +7,15 @@
module Utils.Print.Letters where
-- import Import.NoModel
import Import hiding (embedFile)
import Data.FileEmbed (embedFile)
import Data.Char as Char
import qualified Data.Text as Text
-- import qualified Data.CaseInsensitive as CI
import qualified Data.Foldable as Fold
import qualified Data.ByteString.Lazy as LBS
import Control.Monad.Except
import Import hiding (embedFile)
import Data.FileEmbed (embedFile)
import qualified Text.Pandoc as P
import qualified Text.Pandoc.PDF as P
@ -27,7 +27,7 @@ import Text.Hamlet
-- import System.Process.Typed -- for calling pdftk for pdf encryption
-- import Handler.Utils.Users
-- import Handler.Utils.DateTime
import Handler.Utils.DateTime
-- import Handler.Utils.Mail
-- import Handler.Utils.Widgets (nameHtml, nameHtml')
-- import Handler.Utils.Avs (updateReceivers)
@ -159,6 +159,9 @@ paperKind PlainLogo = "a4logo"
-- PrintJobs --
---------------
apcIdentSeparator :: Text
apcIdentSeparator = "___"
data PrintJobIdentification = PrintJobIdentification
{ pjiName :: Text
, pjiApcAcknowledge :: Text
@ -172,16 +175,14 @@ 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 -> Char -> LetterKind -> Text -> P.Meta
mkApcIdent uuid envelope lk apcAck = P.Meta $ toMeta "apc-ident" apcIdent
where
apcSep = "___"
apcIdent = Text.filter apcAcceptedChars $ Text.intercalate apcSep
mkApcIdent :: CryptoUUIDUser -> Char -> LetterKind -> Text -> Text -> Text
mkApcIdent uuid envelope lk tnow apcAck = Text.filter apcAcceptedChars $ Text.intercalate apcIdentSeparator
[ tshow (ciphertext uuid) <> Text.cons '-' (Text.singleton envelope)
, paperKind lk
, tnow
, apcAck
]
-- | Character allowed to be included in the APC identifier string printed in white in the header of all printed letters
apcAcceptedChars :: Char -> Bool
apcAcceptedChars '-' = True
@ -215,5 +216,15 @@ class MDLetter l where
getLetterKind :: Proxy l -> LetterKind
getTemplate :: Proxy l -> Text
letterApcIdent :: MDLetter l => CryptoUUIDUser -> l -> P.Meta
letterApcIdent uuid l = mkApcIdent uuid (getLetterEnvelope l) (getLetterKind $ pure l) (pjiApcAcknowledge $ getPJId l)
letterApcIdent :: (MDLetter l, MonadHandler m) => l -> CryptoUUIDUser -> UTCTime -> m Text
letterApcIdent l uuid now = do
-- now <- liftIO getCurrentTime
tnow <- formatTime' "%y%m%d-%H" now
return $ mkApcIdent uuid (getLetterEnvelope l) (getLetterKind $ pure l) tnow (pjiApcAcknowledge $ getPJId l)
addApcIdent :: Text -> P.Meta
addApcIdent = P.Meta . toMeta "apc-ident"
getApcIdent :: P.Meta -> Maybe Text
getApcIdent (P.lookupMeta "apc-ident" -> Just (P.MetaString t)) = Just t
getApcIdent _ = Nothing

2
templates/letter/din5008.latex
View File

@ -80,7 +80,7 @@ $endif$
%\usepackage[a4paper, bottom=8cm, top=3cm]{geometry} %%% THIS HAD NO EFFECT AT ALL
%\usepackage{parskip}% might be useful for pandoc tightlist
\usepackage{parskip}% might be useful for pandoc tightlist
\usepackage{graphics}
\usepackage{xcolor}

2
templates/letter/din5008with_pin.latex
View File

@ -80,7 +80,7 @@ $endif$
%\usepackage[a4paper, bottom=8cm, top=3cm]{geometry} %%% THIS HAD NO EFFECT AT ALL
%\usepackage{parskip}% might be useful for pandoc tightlist
\usepackage{parskip}% might be useful for pandoc tightlist
\usepackage{graphics}
\usepackage{xcolor}

2
templates/letter/plain_article.latex
View File

@ -72,7 +72,7 @@ $endif$
%\usepackage[a4paper, bottom=8cm, top=3cm]{geometry} %%% THIS HAD NO EFFECT AT ALL
%\usepackage{parskip}% might be useful for pandoc tightlist
\usepackage{parskip}% might be useful for pandoc tightlist
\usepackage{graphics}
\usepackage{xcolor}

10
test/Database/Fill.hs
View File

@ -106,9 +106,9 @@ fillDb = do
, userCompanyPersonalNumber = Just "00000"
, userCompanyDepartment = Nothing
, userPinPassword = Nothing
, userPostAddress = Nothing
, userPostAddress = Just $ markdownToStoredMarkup ("Büro 127 \nMathematisches Institut der Ludwig-Maximilians-Universität München \nTheresienstr. 39 \nD-80333 München"::Text)
, userPostLastUpdate = Nothing
, userPrefersPostal = False
, userPrefersPostal = True
, userExamOfficeGetSynced = userDefaultExamOfficeGetSynced
, userExamOfficeGetLabels = userDefaultExamOfficeGetLabels
}
@ -145,10 +145,10 @@ fillDb = do
, userTelephone = Nothing
, userCompanyPersonalNumber = Nothing
, userCompanyDepartment = Nothing
, userPinPassword = Nothing
, userPostAddress = Nothing
, userPinPassword = Just "tomatenmarmelade"
, userPostAddress = Just $ markdownToStoredMarkup ("Erdbeerweg 24 \n12345 **Schlumpf**hausen \nTraumland"::Text)
, userPostLastUpdate = Nothing
, userPrefersPostal = False
, userPrefersPostal = True
, userExamOfficeGetSynced = userDefaultExamOfficeGetSynced
, userExamOfficeGetLabels = userDefaultExamOfficeGetLabels
}