From 583a0a254da1e275d6557632343842814d7214b1 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 22 Mar 2023 10:35:39 +0000 Subject: [PATCH] chore(letter): test printing with new ident strings working again --- models/print.model | 4 +-- src/Handler/Admin/Test.hs | 6 ++-- src/Handler/PrintCenter.hs | 15 ++++---- src/Model/Types/Lms.hs | 4 +-- src/Utils/Print.hs | 50 ++++++++++++++------------ src/Utils/Print/Letters.hs | 35 +++++++++++------- templates/letter/din5008.latex | 2 +- templates/letter/din5008with_pin.latex | 2 +- templates/letter/plain_article.latex | 2 +- test/Database/Fill.hs | 10 +++--- 10 files changed, 74 insertions(+), 56 deletions(-) diff --git a/models/print.model b/models/print.model index 4e9073be1..69adcc7ba 100644 --- a/models/print.model +++ b/models/print.model @@ -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 \ No newline at end of file diff --git a/src/Handler/Admin/Test.hs b/src/Handler/Admin/Test.hs index 1441e94b4..ca0d2aae8 100644 --- a/src/Handler/Admin/Test.hs +++ b/src/Handler/Admin/Test.hs @@ -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 diff --git a/src/Handler/PrintCenter.hs b/src/Handler/PrintCenter.hs index a5cebe670..10aa628ce 100644 --- a/src/Handler/PrintCenter.hs +++ b/src/Handler/PrintCenter.hs @@ -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 diff --git a/src/Model/Types/Lms.hs b/src/Model/Types/Lms.hs index 1a011c8e7..279173b65 100644 --- a/src/Model/Types/Lms.hs +++ b/src/Model/Types/Lms.hs @@ -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 diff --git a/src/Utils/Print.hs b/src/Utils/Print.hs index da2d1a912..25e09b959 100644 --- a/src/Utils/Print.hs +++ b/src/Utils/Print.hs @@ -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 diff --git a/src/Utils/Print/Letters.hs b/src/Utils/Print/Letters.hs index c9eaa0bf1..4b5016fe1 100644 --- a/src/Utils/Print/Letters.hs +++ b/src/Utils/Print/Letters.hs @@ -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 \ No newline at end of file diff --git a/templates/letter/din5008.latex b/templates/letter/din5008.latex index 7be904aed..c6c88f17e 100644 --- a/templates/letter/din5008.latex +++ b/templates/letter/din5008.latex @@ -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} diff --git a/templates/letter/din5008with_pin.latex b/templates/letter/din5008with_pin.latex index 673d104c9..22e3b0a0f 100644 --- a/templates/letter/din5008with_pin.latex +++ b/templates/letter/din5008with_pin.latex @@ -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} diff --git a/templates/letter/plain_article.latex b/templates/letter/plain_article.latex index 33d2c2285..ba833c37b 100644 --- a/templates/letter/plain_article.latex +++ b/templates/letter/plain_article.latex @@ -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} diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 492bc7f73..00ba25e7e 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -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 }