From b84a6f2cf983bbe333ff88e00956a3dde20d2b50 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 21 Mar 2023 12:35:30 +0000 Subject: [PATCH] refactor(letter): adapt test letter printing --- .../categories/qualification/de-de-formal.msg | 1 + .../categories/qualification/en-eu.msg | 1 + models/lms.model | 2 +- src/Handler/Admin/Test.hs | 66 +++---- src/Handler/PrintCenter.hs | 182 ++++++------------ src/Handler/Users.hs | 4 +- src/Utils.hs | 2 +- src/Utils/Print.hs | 42 ++-- src/Utils/Print/Letters.hs | 14 +- src/Utils/Print/RenewQualification.hs | 4 +- templates/i18n/admin-test/de-de-formal.hamlet | 4 +- templates/i18n/admin-test/en-eu.hamlet | 4 +- .../mail/body/qualificationRenewal.hamlet | 2 +- templates/system-message.hamlet | 6 +- 14 files changed, 133 insertions(+), 201 deletions(-) diff --git a/messages/uniworx/categories/qualification/de-de-formal.msg b/messages/uniworx/categories/qualification/de-de-formal.msg index e7e254199..9ee9875a8 100644 --- a/messages/uniworx/categories/qualification/de-de-formal.msg +++ b/messages/uniworx/categories/qualification/de-de-formal.msg @@ -29,6 +29,7 @@ QualificationUserNoRenewal: Läuft ohne Benachrichtigung aus QualificationUserNone: Für diese Person sind keine Qualifikationen registriert. QualificationBlockReason: Entzugsbegründung LmsUser: Inhaber +LmsURL: Link E-Learning TableLmsEmail: E‑Mail TableLmsIdent: LMS Identifikation TableLmsElearning: E‑Learning diff --git a/messages/uniworx/categories/qualification/en-eu.msg b/messages/uniworx/categories/qualification/en-eu.msg index babf4696c..2d7eaec78 100644 --- a/messages/uniworx/categories/qualification/en-eu.msg +++ b/messages/uniworx/categories/qualification/en-eu.msg @@ -29,6 +29,7 @@ QualificationUserNoRenewal: Expires without further notification QualificationUserNone: No registered qualifications for this person. QualificationBlockReason: Reason for revoking LmsUser: Licensee +LmsURL: Link E-learning TableLmsEmail: Email TableLmsIdent: LMS Identifier TableLmsPin: E‑learning pin diff --git a/models/lms.model b/models/lms.model index ac2128e55..f96aca375 100644 --- a/models/lms.model +++ b/models/lms.model @@ -22,7 +22,7 @@ Qualification -- across all schools, only one qualification may be a driving licence: UniqueQualificationAvsLicence avsLicence !force -- NOTE: two NULL values are not equal for the purpose of Uniqueness constraints! - deriving Generic + deriving Eq Generic -- TODOs: -- - Enstehen Kosten, wenn Teilnehmer für KnowHow eingereiht werden, aber nicht am Kurs teilnehmen? diff --git a/src/Handler/Admin/Test.hs b/src/Handler/Admin/Test.hs index 5346c6aa9..1441e94b4 100644 --- a/src/Handler/Admin/Test.hs +++ b/src/Handler/Admin/Test.hs @@ -10,7 +10,6 @@ module Handler.Admin.Test import Import import Utils.Print -import Utils.Print.Letters import Handler.Utils import Jobs @@ -23,10 +22,6 @@ import qualified Data.ByteString.Lazy as LBS import qualified Data.Set as Set import qualified Data.Map as Map -import qualified Text.Pandoc as P -import qualified Text.Pandoc.PDF as P -import qualified Text.Pandoc.Builder as P - -- just to test i18nHamlet import Text.Hamlet -- import Handler.Utils.I18n @@ -303,36 +298,31 @@ postAdminTestR = do getAdminTestPdfR :: Handler TypedContent getAdminTestPdfR = do - -- uUser <- maybeAuth -- to determine language for test - templates <- liftIO $ do - letter_tp <- P.compileTemplate "" templateRenewal - din5008 <- P.compileTemplate "" templateDIN5008 - now <- getCurrentTime - return (now, letter_tp, din5008) - case templates of - (_,Left err,_) -> sendResponseStatus internalServerError500 $ "Markdown template error: \n" <> err - (_,_,Left err) -> sendResponseStatus internalServerError500 $ "LaTeX template error: \n" <> err - (now, Right templ, Right latex) -> do - content <- liftIO . P.runIO $ do - let texopts = [] - readeropts = def { P.readerExtensions = P.pandocExtensions } - writeropts1 = def { P.writerTemplate = Just templ } - writeropts2 = def { P.writerTemplate = Just latex } - -- https://github.com/jgm/pandoc/issues/1950 - -- using markdown as a template for itself for interpolation: - doc1 <- P.readMarkdown readeropts templateRenewal - doc2 <- P.writeMarkdown writeropts1 doc1 - doc3 <- P.readMarkdown readeropts doc2 - P.makePDF "lualatex" texopts P.writeLaTeX writeropts2 $ - P.setDate (P.text . tshow $ utctDay now) doc3 - case content of - Right (Right bs) -> do - liftIO $ LBS.writeFile "/tmp/generated.pdf" bs - mbEncPdf <- encryptPDF "tomatenmarmelade" bs - case mbEncPdf of - Left err -> sendResponseStatus internalServerError500 $ "PDFtk error: \n" <> err - Right encPdf -> do - liftIO $ LBS.writeFile "/tmp/crypted.pdf" encPdf - sendByteStringAsFile "demoPDF.pdf" (LBS.toStrict bs) now - Right (Left err) -> sendResponseStatus internalServerError500 $ decodeUtf8 $ LBS.toStrict $ "LaTeX compile error: \n" <> err - Left err -> sendResponseStatus internalServerError500 $ "Pandoc error: \n" <> P.renderError err + usr <- requireAuth -- to determine language and recipient for test + qual <- fromMaybeM + (addMessage Error "Keine Qualifikation in der Datenbank zur Erzeugung eines Test-PDFs gefunden." >> redirect AdminTestR) + (runDB $ selectFirst [] [Asc QualificationAvsLicence, Asc QualificationShorthand]) + now <- liftIO getCurrentTime + let nowaday = utctDay now + letter = LetterRenewQualificationF + { lmsLogin = LmsIdent "abcdefgh" + , lmsPin = "12345678" + , qualHolderID = usr ^. _entityKey + , qualHolderDN = usr ^. _userDisplayName + , qualHolderSN = usr ^. _userSurname + , qualExpiry = succ nowaday + , qualId = qual ^. _entityKey + , qualName = qual ^. _qualificationName . _CI + , qualShort = qual ^. _qualificationShorthand . _CI + , qualSchool = qual ^. _qualificationSchool + , qualDuration = qual ^. _qualificationValidDuration + } + renderLetter usr letter >>= \case + Left err -> sendResponseStatus internalServerError500 $ "PDF generation failed: \n" <> err + Right pdf -> do + liftIO $ LBS.writeFile "/tmp/generated.pdf" pdf + encryptPDF "tomatenmarmelade" pdf >>= \case + Left err -> sendResponseStatus internalServerError500 $ "PDFtk error: \n" <> err + Right encPdf -> do + liftIO $ LBS.writeFile "/tmp/crypted.pdf" encPdf + sendByteStringAsFile "demoPDF.pdf" (LBS.toStrict pdf) now diff --git a/src/Handler/PrintCenter.hs b/src/Handler/PrintCenter.hs index e85fa161b..a5cebe670 100644 --- a/src/Handler/PrintCenter.hs +++ b/src/Handler/PrintCenter.hs @@ -18,19 +18,12 @@ import Import import qualified Data.Set as Set import qualified Data.Map as Map --- import qualified Data.Text as T --- import qualified Data.Text.Lazy as LT --- import qualified Data.ByteString.Lazy as LBS -import qualified Text.Pandoc as P -import qualified Text.Pandoc.Builder as P - import Database.Persist.Sql (updateWhereCount) import qualified Database.Esqueleto.Experimental as Ex -- needs TypeApplications Lang-Pragma import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import Database.Esqueleto.Utils.TH -import qualified Control.Monad.State.Class as State import Utils.Print -- import Data.Aeson (encode) -- import qualified Data.Text as Text @@ -44,35 +37,6 @@ import qualified Data.Csv as Csv single :: (k,a) -> Map k a single = uncurry Map.singleton -data MetaPinRenewal = MetaPinRenewal - { mppExaminee :: Text - , mppAddress :: StoredMarkup - , mppLogin :: Text - , mppPin :: Text - , mppURL :: Maybe URI - , mppDate :: Day - , mppLang :: Lang - , mppOpening :: Maybe Text - , mppClosing :: Maybe Text - , mppSupervisor:: Maybe Text - } - deriving (Eq, Ord, Show, Generic) - --- TODO: just for testing, remove in production -instance Default MetaPinRenewal where - def = MetaPinRenewal - { mppExaminee = "Papa Schlumpf" - , mppAddress = plaintextToStoredMarkup ("Erdbeerweg 42\n98726 Schlumpfhausen"::Text) - , mppLogin = "keiner123" - , mppPin = "89998a" - , mppURL = Nothing - , mppDate = fromGregorian 2022 07 27 - , mppLang = "de-de" - , mppOpening = Just "Lieber Schlumpfi," - , mppClosing = Nothing - , mppSupervisor= Nothing - } - data LRQF = LRQF { lrqfUser :: Either UserEmail UserId , lrqfSuper :: Maybe (Either UserEmail UserId) @@ -80,81 +44,50 @@ data LRQF = LRQF , lrqfIdent :: LmsIdent , lrqfPin :: Text , lrqfExpiry:: Day - } deriving (Eq, Ord, Show, Generic) + } deriving (Eq, Generic) makeRenewalForm :: Maybe LRQF -> Form LRQF makeRenewalForm tmpl = identifyForm FIDLmsLetter . validateForm validateLetterRenewQualificationF $ \html -> do - now_day <- utctDay <$> liftIO getCurrentTime + -- now_day <- utctDay <$> liftIO getCurrentTime flip (renderAForm FormStandard) html $ LRQF - <$> areq userField (fslI MsgLmsUser) (lrqfUser <$> tmpl) - <*> aopt userField (fslI MsgTableSupervisor) (lrqfSuper <$> tmpl) - <*> areq qualificationFieldEnt (fslI MsgQualificationName) (lrqfQuali <$> tmpl) - <$> areq lmsField (fslI MsgTableLmsIdent) (lrqfIdent <$> tmpl) - <*> areq textField (fslI MsgTableLmsPin) (lrqfPin <$> tmpl) - <*> areq dayField (fslI MsgMsgLmsQualificationValidUntil) (lrqfExpiry <$> tmpl) + <$> areq (userField False Nothing) (fslI MsgLmsUser) (lrqfUser <$> tmpl) + <*> aopt (userField False Nothing) (fslI MsgTableSupervisor) (lrqfSuper <$> tmpl) + <*> areq qualificationFieldEnt (fslI MsgQualificationName) (lrqfQuali <$> tmpl) + <*> areq lmsField (fslI MsgTableLmsIdent) (lrqfIdent <$> tmpl) + <*> areq textField (fslI MsgTableLmsPin) (lrqfPin <$> tmpl) + <*> areq dayField (fslI MsgLmsQualificationValidUntil) (lrqfExpiry <$> tmpl) where - lmsField = convertField LmsIdent getLmsIdent + lmsField = convertField LmsIdent getLmsIdent textField -validateLetterRenewQualificationF :: FormValidator MetaPinRenewal Handler () +validateLetterRenewQualificationF :: FormValidator LRQF Handler () validateLetterRenewQualificationF = -- do - -- MetaPinRenewal{..} <- State.get + -- LRQF{..} <- State.get return () -lrqf2letter :: LRQF -> DB (LetterRenewQualificationF, Entity User) +lrqf2letter :: LRQF -> DB (Entity User, LetterRenewQualificationF) lrqf2letter LRQF{..} = do - usr <- getUser lrqfUser - rcvr <- getUser <$> lrqfSuper + usr <- getUser lrqfUser + rcvr <- mapM getUser lrqfSuper let letter = LetterRenewQualificationF - { lmsLogin = lrqfIdent - , lmsPin = lrqfPin - , qualHolderID = usr ^. _entityKey - , qualHolderDN = usr ^. _userDisplayName - , qualHolderSN = usr ^. _userSurname - , qualExpiry = lrqfExpiry - , qualId = lrqfQuali ^. _entityKey - , qualName = lrqfQuali ^. _qualificationName - , qualShort = lrqfQuali ^. _qualificationShort - , qualSchool = lrqfQuali ^. _qualificationSchool - , qualDuration = lrqfQuali ^. _qualificationValidDuration - } - return (letter, fromMaybe usr rcvr) + { lmsLogin = lrqfIdent + , lmsPin = lrqfPin + , qualHolderID = usr ^. _entityKey + , qualHolderDN = usr ^. _userDisplayName + , qualHolderSN = usr ^. _userSurname + , qualExpiry = lrqfExpiry + , qualId = lrqfQuali ^. _entityKey + , qualName = lrqfQuali ^. _qualificationName . _CI + , qualShort = lrqfQuali ^. _qualificationShorthand . _CI + , qualSchool = lrqfQuali ^. _qualificationSchool + , qualDuration = lrqfQuali ^. _qualificationValidDuration + } + return (fromMaybe usr rcvr, letter) where - getUser :: Either UserEmail UserId -> Entity User + getUser :: Either UserEmail UserId -> DB (Entity User) getUser (Right uid) = getEntity404 uid getUser (Left mail) = getBy404 $ UniqueEmail mail - -mprToMeta :: MetaPinRenewal -> P.Meta -mprToMeta MetaPinRenewal{..} = mkMeta - -- formatTimeUser SelFormatDate mppDate mppExaminee - [ toMeta "examinee" mppExaminee - , toMeta "address" (mppExaminee : (mppAddress & html2textlines)) - , toMeta "login" mppLogin - , toMeta "pin" mppPin - , mbMeta "url" (mppURL <&> tshow) - , toMeta "date" (mppDate & tshow) -- rendering according to user preference requires Handler Monad; deferred to Post-processing of P.Meta - , toMeta "lang" mppLang - , mbMeta keyOpening mppOpening - , mbMeta keyClosing mppClosing - , mbMeta "supervisor" mppSupervisor - ] - where - deOrEn = if isDe mppLang then "de" else "en" - keyOpening = deOrEn <> "-opening" - keyClosing = deOrEn <> "-closing" - -mprToMetaUser :: (MonadHandler m, HandlerSite m ~ UniWorX) => Entity User -> MetaPinRenewal -> m P.Meta -mprToMetaUser entUser@Entity{entityVal = u} mpr = do - let userLang = userLanguages u >>= (listToMaybe . view _Wrapped) -- auch möglich `op Languages` statt `view _Wrapped` - meta = mprToMeta mpr{ mppExaminee = userDisplayName u - -- , mppAddress = userDisplayName u : html2textlines userAddress --TODO once we have User addresses within the DB - , mppLang = fromMaybe (mppLang mpr) userLang -- check if this is the desired behaviour! - } - userDate <- formatTimeUser SelFormatDate (mppDate mpr) (Just entUser) - return $ P.setMeta "date" userDate meta - - data PJTableAction = PJActAcknowledge deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) @@ -340,40 +273,33 @@ postPrintCenterR = do getPrintSendR, postPrintSendR :: Handler Html getPrintSendR = postPrintSendR postPrintSendR = do - ((sendResult, sendWidget), sendEnctype) <- runFormPost $ makeRenewalForm $ Just def - let procFormSend mpr = do - receivers <- runDB $ Ex.select $ do - user <- Ex.from $ Ex.table @User - Ex.where_ $ E.val (mppExaminee mpr) `E.isInfixOf` (user E.^. UserIdent) - pure user - letters <- case receivers of - [] -> pure . (Nothing ,) <$> pdfRenewal (mprToMeta mpr) - _ -> forM receivers $ \usr -> do - meta <- mprToMetaUser usr mpr - pdf <- pdfRenewal meta - return (Just $ entityKey usr, pdf) - oks <- forM letters $ \case - (mbRecipient, Right bs) -> do - -- liftIO $ LBS.writeFile "/tmp/generated.pdf" bs -- DEBUGGING ONLY - -- addMessage Warning "PDF momentan nur gespeicher unter /tmp/generated.pdf" - uID <- maybeAuthId - runDB (sendLetter' "Test-Brief" "abcdefgh" bs (mbRecipient, uID) Nothing Nothing Nothing) >>= \case -- calls lpr - Left err -> do - let msg = "PDF printing failed with error: " <> err - $logErrorS "LPR" msg - addMessage Error $ toHtml msg - pure False - Right (ok, fpath) -> do - let response = if null ok then mempty else " Response: " <> ok - addMessage Success $ toHtml $ "Druckauftrag angelegt: " <> pack fpath <> response - pure True - (Nothing, Left err) -> do - addMessage Error $ toHtml err + usr <- requireAuth -- to determine language and recipient for test + mbQual <- runDB $ selectFirst [] [Asc QualificationAvsLicence, Asc QualificationShorthand] + now <- liftIO getCurrentTime + let nowaday = utctDay now + mkLetter qual = LRQF + { lrqfUser = Right $ usr ^. _entityKey + , lrqfSuper = Nothing + , lrqfQuali = qual + , lrqfIdent = LmsIdent "stuvwxyz" + , lrqfPin = "76543210" + , lrqfExpiry = succ nowaday + } + def_lrqf = mkLetter <$> mbQual + + ((sendResult, sendWidget), sendEnctype) <- runFormPost $ makeRenewalForm def_lrqf + let procFormSend lrqf = do + ok <- (runDB (lrqf2letter lrqf) >>= printLetter) >>= \case + Left err -> do + let msg = "PDF printing failed with error: " <> err + $logErrorS "LPR" msg + addMessage Error $ toHtml msg pure False - (Just uid, Left err) -> do - addMessage Error . toHtml $ "For uid " <> tshow uid <> ": " <> err - pure False - when (or oks) $ redirect PrintCenterR + Right (ok, fpath) -> do + let response = if null ok then mempty else " Response: " <> ok + addMessage Success $ toHtml $ "Druckauftrag angelegt: " <> pack fpath <> response + pure True + when ok $ redirect PrintCenterR formResult sendResult procFormSend -- actionUrl <- fromMaybe AdminAvsR <$> getCurrentRoute siteLayoutMsg MsgPrintManualRenewal $ do diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index d66aed45e..605b49f3d 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -188,10 +188,10 @@ postUsersR = do acts = mconcat [ singletonMap UserLdapSync $ pure UserLdapSyncData , singletonMap UserAddSupervisor $ UserAddSupervisorData - <$> apopt (textField & cfAnySeparatedSet) (fslI MsgMppSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing + <$> apopt (textField & cfAnySeparatedSet) (fslI MsgTableSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing <*> apopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip) (Just True) , singletonMap UserSetSupervisor $ UserSetSupervisorData - <$> apopt (textField & cfAnySeparatedSet) (fslI MsgMppSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing + <$> apopt (textField & cfAnySeparatedSet) (fslI MsgTableSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing <*> apopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip) (Just True) , singletonMap UserRemoveSupervisor $ pure UserRemoveSupervisorData ] diff --git a/src/Utils.hs b/src/Utils.hs index bffd6243f..107bdd282 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -275,7 +275,7 @@ addAttrsClass cl attrs = ("class", cl') : noClAttrs -- tickmark :: IsString a => a -- tickmark = fromString "✔" -nonBreakableDash :: Text -- used directly in several Messages +nonBreakableDash :: Text -- used directly in several messages nonBreakableDash = "‑" -- | Deprecated, replace with Data.Text.elem, once a newer version of Data.Text is available diff --git a/src/Utils/Print.hs b/src/Utils/Print.hs index fdb6dc7fc..da2d1a912 100644 --- a/src/Utils/Print.hs +++ b/src/Utils/Print.hs @@ -7,6 +7,7 @@ module Utils.Print ( renderLetter -- used for generating letter pdfs , sendEmailOrLetter -- directly print or sends by email + , printLetter -- always send a letter , encryptPDF , sanitizeCmdArg, validCmdArgument -- , compileTemplate, makePDF @@ -156,20 +157,27 @@ renderLetter rcvrEnt@Entity{entityKey=uid, entityVal=rcvr} mdl = do --------------- -- Only used in print-test-handler for PrintSendR -sendLetter' :: Text -> Text -> LBS.ByteString -> (Maybe UserId, Maybe UserId) -> Maybe CourseId -> Maybe QualificationId -> Maybe LmsIdent -> DB (Either Text (Text, FilePath)) -sendLetter' printJobName printJobApcAcknowledge pdf (printJobRecipient, printJobSender) printJobCourse printJobQualification printJobLmsUser = - sendLetter pdf PrintJobIdentification - { pjiName = printJobName - , pjiApcAcknowledge = printJobApcAcknowledge - , pjiRecipient = printJobRecipient - , pjiSender = printJobSender - , pjiCourse = printJobCourse - , pjiQualification = printJobQualification - , pjiLmsUser = printJobLmsUser - } +printLetter :: (MDLetter l) => (Entity User, l) -> Handler (Either Text (Text, FilePath)) +printLetter (rcvr, letter) = do + pdf <- renderLetter rcvr letter + let protoPji = getPJId letter + pji = protoPji + { pjiRecipient = Just $ entityKey rcvr + , pjiName = "TEST_" <> pjiName protoPji + } + actRight pdf $ runDB . printLetter' pji -sendLetter :: LBS.ByteString -> PrintJobIdentification -> DB (Either Text (Text, FilePath)) -sendLetter pdf PrintJobIdentification{pjiName = printJobName, pjiApcAcknowledge = printJobApcAcknowledge, pjiRecipient = printJobRecipient, pjiSender = printJobSender, pjiCourse = printJobCourse, pjiQualification = printJobQualification, pjiLmsUser = printJobLmsUser} = do +printLetter' :: PrintJobIdentification -> LBS.ByteString -> DB (Either Text (Text, FilePath)) +printLetter' pji pdf = do + let PrintJobIdentification + { pjiName = printJobName + , pjiApcAcknowledge = printJobApcAcknowledge + , pjiRecipient = printJobRecipient + , pjiSender = printJobSender + , pjiCourse = printJobCourse + , pjiQualification = printJobQualification + , pjiLmsUser = printJobLmsUser + } = pji recipient <- join <$> mapM get printJobRecipient sender <- join <$> mapM get printJobSender course <- join <$> mapM get printJobCourse @@ -194,8 +202,8 @@ sendLetter pdf PrintJobIdentification{pjiName = printJobName, pjiApcAcknowledge return $ Right (ok, printJobFilename) {- -sendLetter'' :: _ -> DB PureFile -sendLetter'' _ = do +printLetter'' :: _ -> DB PureFile +printLetter'' _ = do ... return $ File { fileTitle = printJobFilename , fileModified = printJobCreated @@ -226,7 +234,7 @@ sendEmailOrLetter recipient letter = do $logErrorS "LETTER" msg return False Right pdf | preferPost -> -- send printed letter - runDB (sendLetter pdf pjid{ pjiRecipient = Just svr}) >>= \case + runDB (printLetter' pjid{pjiRecipient = Just svr} pdf) >>= \case 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 @@ -329,7 +337,7 @@ encryptPDF pw bs = over _Left (decodeUtf8 . LBS.toStrict) . exit2either <$> read -- The cups version of lpr is instead used like so: -- > lpr -P fradrive -H fravm017173.fra.fraport.de:515 -T printJobName - --- | Internal only, use `sendLetter` instead +-- | Internal only, use `printLetter` instead lprPDF :: (MonadHandler m, HasAppSettings (HandlerSite m)) => Text -> LBS.ByteString -> m (Either Text Text) lprPDF jb bs = do mbLprServerArg <- $cachedHereBinary ("lprServer"::Text) getLprServerArg diff --git a/src/Utils/Print/Letters.hs b/src/Utils/Print/Letters.hs index 9c1a4fe6c..c9eaa0bf1 100644 --- a/src/Utils/Print/Letters.hs +++ b/src/Utils/Print/Letters.hs @@ -7,7 +7,7 @@ module Utils.Print.Letters where -- import Import.NoModel --- import Data.Char (isSeparator) +import Data.Char as Char import qualified Data.Text as Text -- import qualified Data.CaseInsensitive as CI import qualified Data.Foldable as Fold @@ -173,15 +173,21 @@ 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" $ apcSep <> apcIdent <> apcSep +mkApcIdent uuid envelope lk apcAck = P.Meta $ toMeta "apc-ident" apcIdent where apcSep = "___" - apcIdent = Text.intercalate apcSep - [ tshow uuid <> Text.cons '-' (Text.singleton envelope) + apcIdent = Text.filter apcAcceptedChars $ Text.intercalate apcSep + [ tshow (ciphertext uuid) <> Text.cons '-' (Text.singleton envelope) , paperKind lk , 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 +apcAcceptedChars '_' = True +apcAcceptedChars c = isAlphaNum c + ------------------ diff --git a/src/Utils/Print/RenewQualification.hs b/src/Utils/Print/RenewQualification.hs index daa3bf107..c4983c760 100644 --- a/src/Utils/Print/RenewQualification.hs +++ b/src/Utils/Print/RenewQualification.hs @@ -9,7 +9,7 @@ module Utils.Print.RenewQualification where import Import import Text.Hamlet --- import Data.Char (isSeparator) +import Data.Char as Char import qualified Data.Text as Text import qualified Data.CaseInsensitive as CI @@ -48,7 +48,7 @@ letterRenewalQualificationFData LetterRenewQualificationF{lmsLogin} = LetterRene instance MDLetter LetterRenewQualificationF where getLetterKind _ = PinLetter - getLetterEnvelope l = maybe 'q' fst $ Text.uncons (qualShort l) + getLetterEnvelope l = maybe 'q' (Char.toLower . 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 } = diff --git a/templates/i18n/admin-test/de-de-formal.hamlet b/templates/i18n/admin-test/de-de-formal.hamlet index 38eaa2143..3710fb6b9 100644 --- a/templates/i18n/admin-test/de-de-formal.hamlet +++ b/templates/i18n/admin-test/de-de-formal.hamlet @@ -81,10 +81,10 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later

Erzeugtes PDF herunterladen:

- Hier ist ein + Hier ist ein # Download-Link - für eine PDF Vorschau. + \ für eine PDF Vorschau.

Zusätzlich wird dabei im Verzeichnis /tmp das PDF mit und ohne Passwort gespeichert. \ No newline at end of file diff --git a/templates/i18n/admin-test/en-eu.hamlet b/templates/i18n/admin-test/en-eu.hamlet index acc764944..b364e23c8 100644 --- a/templates/i18n/admin-test/en-eu.hamlet +++ b/templates/i18n/admin-test/en-eu.hamlet @@ -81,10 +81,10 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later

Download a generated PDF

- Here is a + Here is a # Download-Link - for a preview. + \ for a preview.

Following the link, the pdf will also be saved to the /tmp directory, once without diff --git a/templates/mail/body/qualificationRenewal.hamlet b/templates/mail/body/qualificationRenewal.hamlet index 2f5d78619..5dea6b86f 100644 --- a/templates/mail/body/qualificationRenewal.hamlet +++ b/templates/mail/body/qualificationRenewal.hamlet @@ -22,4 +22,4 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later _{SomeMessage MsgLmsRenewalInstructions} # - _{SomeMessage MsgMppURL} #{lmsUrl} + _{SomeMessage MsgLmsURL} #{lmsUrl} diff --git a/templates/system-message.hamlet b/templates/system-message.hamlet index 70df68367..7570e18b4 100644 --- a/templates/system-message.hamlet +++ b/templates/system-message.hamlet @@ -13,6 +13,6 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later $maybe (messageEditModal, translationAddModal, translationsEditModal) <- forms

- ^{messageEditModal} - ^{translationAddModal} - ^{translationsEditModal} + ^{messageEditModal} # + ^{translationAddModal} # + ^{translationsEditModal} #