-- SPDX-FileCopyrightText: 2022-23 Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later {-# OPTIONS_GHC -fno-warn-unused-top-binds #-} module Utils.Print ( renderLetterPDF -- used for generating letter pdfs , renderLetters , sendEmailOrLetter -- directly print or sends by email , printLetter -- always send a letter , printHtml -- return letter as Html only , reprintPDF -- send a PDF once more the APC , letterApcIdent -- create acknowledge string for APC , letterFileName -- default filename , encryptPDF , sanitizeCmdArg, sanitizeCmdArg', validCmdArgument -- , compileTemplate, makePDF , _Meta, addMeta , toMeta, mbMeta -- single values , mkMeta, appMeta, applyMetas -- multiple values -- , MDMail -- , MDLetter , SomeLetter(..) , LetterRenewQualificationF(..) , LetterExpireQualification(..) -- , LetterCourseCertificate() , makeCourseCertificates ) where -- import Import.NoModel import Data.Char (isSeparator) import qualified Data.Text as T 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 -- import qualified Text.Pandoc.Builder as P import Text.Hamlet import System.Exit import System.Process.Typed -- for calling pdftk for pdf encryption import Handler.Utils.Memcached import Handler.Utils.Users import Handler.Utils.DateTime import Handler.Utils.Mail import Handler.Utils.Widgets (nameHtml') import Handler.Utils.Avs (updateReceivers) import Jobs.Handler.SendNotification.Utils import Utils.Print.Instances () import Utils.Print.Letters import Utils.Print.SomeLetter import Utils.Print.RenewQualification import Utils.Print.ExpireQualification import Utils.Print.CourseCertificate -- import Model.Types.Markup -- TODO-QSV: should this module be moved accordingly? {- Recall: Funktionen außerhalb der Hanlder-Monade gehören in Utils-Module; ansonsten drohen zyklische Abhängikeiten, d.h. ggf. Funktionen in der HandlerFor-Monade nach Handler.Utils.Print verschieben! -} ------------------------- -- Readers and writers -- ------------------------- -- | Apply StoredMarkup as a template to itself and return the resulting Markup -- This is a hack to allow variable interpolation within a document. -- Pandoc currently only allows interpolation within templates. -- An alternative Route would be to use Builders, but this prevents User-edited Markup Templates -- reTemplateLetter :: P.PandocMonad m => P.Meta -> StoredMarkup -> m Text -- reTemplateLetter meta StoredMarkup{..} = do -- tmpl <- compileTemplate strictMarkupInput -- doc <- areader readerOpts strictMarkupInput -- let writerOpts = def { P.writerExtensions = P.pandocExtensions -- , P.writerTemplate = Just tmpl } -- P.writeMarkdown writerOpts -- $ appMeta setIsDeFromLang -- $ addMeta meta doc -- where -- strictMarkupInput = toStrict markupInput -- readerOpts = def { P.readerExtensions = P.pandocExtensions -- , P.readerStripComments = True -- } -- -- reader :: (P.PandocMonad m, P.ToSources a) => P.ReaderOptions -> a -> m P.Pandoc -- areader = case markupInputFormat of -- MarkupHtml -> P.readHtml -- MarkupMarkdown -> P.readMarkdown -- MarkupPlaintext -> P.readMarkdown -- reTemplateLetter' :: P.PandocMonad m => P.Meta -> Text -> m Text -- reTemplateLetter' meta md = do -- tmpl <- compileTemplate md -- doc <- P.readMarkdown readerOpts md -- let writerOpts = def { P.writerExtensions = P.pandocExtensions -- , P.writerTemplate = Just tmpl } -- P.writeMarkdown writerOpts -- $ appMeta setIsDeFromLang -- $ addMeta meta doc -- where -- readerOpts = def { P.readerExtensions = P.pandocExtensions -- , P.readerStripComments = True -- } -- | read and writes markdown, applying it as its own template to apply meta mdTemplating :: Text -> P.Meta -> HandlerFor UniWorX (Either Text P.Pandoc) mdTemplating template meta = runExceptT $ do let readerOpts = def { P.readerExtensions = P.pandocExtensions , P.readerStripComments = True } -- doc <- ExceptT (pure . over _Left P.renderError . P.runPure $ P.readMarkdown readerOpts template) -- tmpl <- ExceptT (pure . over _Left P.renderError . P.runPure $ compileTemplate template) doc <- ExceptT $ memcachedBy (Just . Right $ 6 * diffHour) ("pandoc-md: \n" <> template) (pure . over _Left P.renderError . P.runPure $ P.readMarkdown readerOpts template) tmpl <- ExceptT $ memcachedBy (Just . Right $ 6 * diffHour) ("template-md: \n" <> template) (pure . over _Left P.renderError . P.runPure $ compileTemplate template) let writerOpts = def { P.writerExtensions = P.pandocExtensions , P.writerTemplate = Just tmpl } ExceptT . pure . over _Left P.renderError . P.runPure $ do md_txt <- P.writeMarkdown writerOpts $ appMeta setIsDeFromLang $ addMeta meta doc addMeta meta <$> P.readMarkdown readerOpts md_txt -- NOTE: meta is lost along the way somehow, despite P.pandocExtensions containing Ext_yaml_metadata_block -- | creates a PDF using a LaTeX template pdfLaTeX :: LetterKind -> P.Pandoc -> HandlerFor UniWorX (Either Text LBS.ByteString) pdfLaTeX lk doc = do -- e_tmpl <- fmap (over _Left P.renderError) . liftIO . P.runIO $ compileTemplate $ templateLatex lk e_tmpl <- memcachedBy (Just . Right $ 6 * diffHour) ("LetterKind-latex: \n" <> tshow lk) (fmap (over _Left P.renderError) . liftIO . P.runIO $ compileTemplate $ templateLatex lk) actRight e_tmpl $ \tmpl -> fmap (over _Left P.renderError) . liftIO . P.runIO $ do let writerOpts = def { P.writerExtensions = P.pandocExtensions , P.writerTemplate = Just tmpl } makePDF writerOpts $ appMeta setIsDeFromLang doc renderLetterPDF :: (MDLetter l) => Entity User -> l -> Text -> Handler (Either Text LBS.ByteString) renderLetterPDF 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 mdl tmpl = getTemplate mdl meta = addApcIdent apcIdent <> letterMeta mdl formatter lang rcvrEnt <> mkMeta [ -- toMeta "lang" lang -- receiver language is decided in MDLetter instance, since some letters have fixed languages toMeta "date" $ format SelFormatDate now , 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 ] e_md <- mdTemplating tmpl meta actRight e_md $ pdfLaTeX kind renderLetterHtml :: (MDLetter l) => Entity User -> l -> Text -> Handler (Either Text Html) renderLetterHtml 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 mdl tmpl = getTemplate mdl meta = addApcIdent apcIdent <> letterMeta mdl formatter lang rcvrEnt <> mkMeta [ -- toMeta "lang" lang -- receiver language is decided in MDLetter instance, since some letters have fixed languages toMeta "date" $ format SelFormatDate now , 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 ] e_md <- mdTemplating tmpl meta actRight e_md $ \md -> pure . over _Left P.renderError . P.runPure $ do html_tmpl <- compileTemplate $ templateHtml kind -- html_tmpl <- ExceptT $ memcachedBy (Just . Right $ 6 * diffHour) ("LetterKind-Html: \n" <> tshow lk) (pure . over _Left P.renderError . P.runPure $ compileTemplate $ templateHtml lk) let writerOpts = def { P.writerExtensions = P.pandocExtensions , P.writerTemplate = Just html_tmpl } P.writeHtml5 writerOpts $ appMeta setIsDeFromLang md -- TODO: apcIdent does not make sense for multiple letters renderLetters :: (MDLetter l, Foldable f) => Entity User -> f l -> Text -> Handler (Either Text LBS.ByteString) renderLetters rcvrEnt@Entity{entityVal=rcvr} mdls apcIdent | Just l <- anyone mdls = 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 l templateCombine _ err@Left{} = pure err templateCombine mdl (Right doc1) = let tmpl = getTemplate mdl meta = addApcIdent apcIdent <> letterMeta mdl formatter lang rcvrEnt <> mkMeta [ -- toMeta "lang" lang -- receiver language is decided in MDLetter instance, since some letters have fixed languages toMeta "date" $ format SelFormatDate now , 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 ] in mdTemplating tmpl meta <&> \case err@Left{} -> err Right doc2 -> Right $ doc1 <> doc2 doc <- foldrM templateCombine (Right mempty) mdls -- result <- actRight doc $ pdfLaTeX kind -- return $ over _Left P.renderError result actRight doc $ pdfLaTeX kind | otherwise = return $ Left "renderLetters received empty set of letters" --------------- -- PrintJobs -- --------------- -- Only used in print-test-handler for PrintSendR printHtml :: (MDLetter l) => Maybe UserId -> (Entity User, l) -> Handler (Either Text Html) printHtml _senderId (rcvr, letter) = do let rcvrId = rcvr ^. _entityKey encRecipient :: CryptoUUIDUser <- encrypt rcvrId now <- liftIO getCurrentTime apcIdent <- letterApcIdent letter encRecipient now renderLetterHtml rcvr letter apcIdent -- Only used in print-test-handler for PrintSendR 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 <- renderLetterPDF rcvr letter apcIdent let protoPji = getPJId letter pji = protoPji { pjiRecipient = Just rcvrId , pjiSender = senderId , pjiName = "TEST_" <> pjiName protoPji , pjiApcAcknowledge = apcIdent } actRight pdf $ runDB . printLetter' pji printLetter' :: PrintJobIdentification -> LBS.ByteString -> DB (Either Text (Text, FilePath)) printLetter' pji pdf = do let PrintJobIdentification { pjiName = printJobName , pjiApcAcknowledge = printJobApcIdent , pjiRecipient = printJobRecipient , pjiSender = printJobSender , pjiCourse = printJobCourse , pjiQualification = printJobQualification , pjiLmsUser = printJobLmsUser , pjiFileName = fName } = pji printJobFilename = T.unpack $ text2asciiAlphaNum fName <> ".pdf" -- printJobFile <- sinkFileDB True $ yield $ LBS.toStrict pdf -- for PrintJobFile :: FileContentReference use this code printJobFile = LBS.toStrict pdf printJobAcknowledged = Nothing lprPDF printJobFilename pdf >>= \case Left err -> do return $ Left err Right ok -> do printJobCreated <- liftIO getCurrentTime -- updateWhere [PrintJobLmsUser ==. printJobLmsUser] [PrintJobLmsUser =. Nothing] -- only one printJob per LmsUser is allowed, since otherwise the qualification table contains double rows insert_ PrintJob {..} return $ Right (ok, printJobFilename) reprintPDF :: Bool -> PrintJobId -> DB (Either Text Text) reprintPDF ignoreReroute pjid = maybeM (return $ Left "Print job id is unknown.") reprint $ get pjid where reprint :: PrintJob -> DB (Either Text Text) reprint pj@PrintJob{..} = do result <- lprPDF' ignoreReroute printJobFilename $ LBS.fromStrict printJobFile whenIsRight result $ const $ do now <- liftIO getCurrentTime insert_ pj{ printJobAcknowledged = Nothing , printJobCreated = now -- , printJobApcIdent = ??? cannot be modified here, since it is included inside the PDF } return result {- printLetter'' :: _ -> DB PureFile printLetter'' _ = do ... return $ File { fileTitle = printJobFilename , fileModified = printJobCreated , fileContent = Just $ yield printJobFile } -} 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 mr <- getMessageRender let pjid = getPJId letter fName = letterFileName letter -- these are only needed if sent by email, but we're lazy anyway undername = underling ^. _userDisplayName -- nameHtml' underling undermail = CI.original $ underling ^. _userEmail mailSubjectRaw = getMailSubject letter mailSubjectSuper = SomeMessage $ "[SUPERVISOR] " <> mr mailSubjectRaw mkMailSubject = bool mailSubjectRaw mailSubjectSuper mkMailBody = getMailBody letter oks <- forM receivers $ \rcvrEnt@Entity{ entityKey = svr, entityVal = rcvrUsr } -> do let supername = rcvrUsr ^. _userDisplayName -- nameHtml' rcvrUsr isSupervised = recipient /= svr mailSubject = mkMailSubject isSupervised encRecipient :: CryptoUUIDUser <- encrypt svr apcIdent <- letterApcIdent letter encRecipient now case getPostalPreferenceAndAddress rcvrUsr of (True, Nothing) -> 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 (True , Just _postal) -> renderLetterPDF rcvrEnt letter apcIdent >>= \case -- send printed letter 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 -> 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 Right (msg,_) | null msg -> return True | otherwise -> do $logWarnS "LETTER" $ "PDF printing to send letter with lpr returned ExitSuccess and the following message: " <> msg return True (False, _) | Just mkMail <- mkMailBody -> renderLetterPDF rcvrEnt letter apcIdent >>= \case -- send Email, but with pdf attached Left err -> do -- pdf generation failed let msg = "Notification failed for " <> tshow encRecipient <> ". PDF attachment generation failed: "<> cropText err <> "For Notification: " <> tshow pjid $logErrorS "LETTER" msg return False Right pdf -> do -- pdf generated, send as email attachment now let pdfPass = case encryptPDFfor letter of NoPassword -> Nothing PasswordSupervisor -> rcvrUsr ^. _userPinPassword PasswordUnderling -> underling ^. _userPinPassword attachment <- case pdfPass of Nothing -> return pdf Just passwd -> encryptPDF passwd pdf >>= \case Right encPdf -> return encPdf Left err -> do 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 mailBody = mkMail formatter userMailTdirect svr $ do replaceMailHeader "Auto-Submitted" $ Just "auto-generated" setSubjectI mailSubject editNotifications <- mkEditNotifications svr addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/genericMailLetter.hamlet") -- wrapper for mailBody addPart (File { fileTitle = fName , fileModified = now , fileContent = Just $ yield $ LBS.toStrict attachment } :: PureFile) return True (False, _) -> renderLetterHtml rcvrEnt letter apcIdent >>= \case -- send Email, render letter directly to html Left err -> do -- html generation failed let msg = "Notification failed for " <> tshow encRecipient <> ". HTML generation failed: "<> cropText err <> "For Notification: " <> tshow pjid $logErrorS "LETTER" msg return False Right html -> do -- html generated, send directly now userMailTdirect svr $ do replaceMailHeader "Auto-Submitted" $ Just "auto-generated" setSubjectI mailSubject addHtmlMarkdownAlternatives html return True return $ or oks ----------------------------- -- Typed Process Utilities -- ----------------------------- -- | Converts Triple consisting of @ExitCode@, Success- and Failure-Value to Either Failue- or Success-Value. -- Returns @Right@ if the @ExitCode@ is @ExitsSuccess, entirely ignoring the Failure-Value, which might contain warning messages. -- To be used with 'System.Process.Typed.readProcess' exit2either :: Monoid a => (ExitCode, a, a) -> Either a a exit2either (ExitSuccess , stdOut, errOut) = Right $ stdOut <> errOut exit2either (ExitFailure _ , stdOut, errOut) = Left $ stdOut <> errOut readProcess' :: MonadIO m => ProcessConfig stdin stdoutIgnored stderrIgnored -> m (ExitCode, Text, Text) readProcess' pc = do (ec, bs_err, bs_out) <- readProcess pc let st_err = decodeUtf8 $ LBS.toStrict bs_err st_out = decodeUtf8 $ LBS.toStrict bs_out return (ec, st_err, st_out) sanitizeCmdArg :: Text -> Text sanitizeCmdArg = T.filter (\c -> c /= '\'' && c /= '"' && c/= '\\' && not (isSeparator c)) sanitizeCmdArg' :: String -> String sanitizeCmdArg' = filter (\c -> c /= '\'' && c /= '"' && c/= '\\' && not (isSeparator c)) -- | Returns Nothing if ok, otherwise the first mismatching character -- Pin Password is used as a commandline argument in Utils.Print.encryptPDF and hence poses a security risk validCmdArgument :: Text -> Maybe Char validCmdArgument t = t `textDiff` sanitizeCmdArg t ----------- -- pdftk -- ----------- -- -- We use the external tool pdftk for PDF encryption like so -- > pdftk in.pdf output out.pdf user_pw tomatenmarmelade -- we can use stdin and std out like so -- > pdftk - output - user_pw tomatenmarmelade -- encryptPDF :: MonadIO m => Text -> LBS.ByteString -> m (Either Text LBS.ByteString) encryptPDF pw bs = over _Left (decodeUtf8 . LBS.toStrict) . exit2either <$> readProcess pc where pw' = sanitizeCmdArg pw pc = setStdin (byteStringInput bs) $ proc "pdftk" [ "-" -- read from stdin , "output", "-" -- write to stdout , "user_pw", T.unpack $ T.strip pw' -- encrypt pdf content , "dont_ask" -- no interaction , "allow", "Printing" -- allow printing despite encryption ] -- Note that pdftk will issue a warning, which will be ignored: -- Warning: Using a password on the command line interface can be insecure. -- Use the keyword PROMPT to supply a password via standard input instead. --------- -- lpr -- --------- -- -- We use the external tool lpr in the variant supplied by busybox -- to print pdfs like so: -- > lpr -P fradrive@fravm017173.fra.fraport.de:515 -J printJobName - -- -- The cups version of lpr is instead used like so: -- > lpr -P fradrive -H fravm017173.fra.fraport.de:515 -T printJobName - -- | Internal only, use `printLetter` instead lprPDF :: (MonadHandler m, HasAppSettings (HandlerSite m)) => FilePath -> LBS.ByteString -> m (Either Text Text) lprPDF = lprPDF' False lprPDF' :: (MonadHandler m, HasAppSettings (HandlerSite m)) => Bool -> FilePath -> LBS.ByteString -> m (Either Text Text) lprPDF' ignoreReroute (sanitizeCmdArg' -> jb) bs = maybeM hdlFail hdlLpr getLprServerArg where hdlFail = return $ Right "Print command ignored due to setting 'mail-reroute-to' being set." hdlLpr lprServerArg = do let pc = setStdin (byteStringInput bs) $ proc "lpr" $ jobname ++ -- -J jobname -- a name for job identification at printing site [ lprServerArg -- -P queue@hostname:port , "-" -- read from stdin ] jobname | null jb = [] | otherwise = ["-J " <> jb] exit2either <$> readProcess' pc getLprServerArg = do rerouteMail <- getsYesod $ view _appMailRerouteTo case (ignoreReroute, rerouteMail) of (False, Just _) -> return Nothing _ -> do LprConf{..} <- getsYesod $ view _appLprConf return . Just $ "-P " <> lprQueue <> "@" <> lprHost <> ":" <> show lprPort {- -- Variant without caching lprPDF' :: (MonadHandler m, HasAppSettings (HandlerSite m)) => String -> LBS.ByteString -> m (Either Text Text) lprPDF' jb bs = do LprConf{..} <- getsYesod $ view _appLprConf let lprServer = lprQueue <> "@" <> lprHost <> ":" <> show lprPort pc = setStdin (byteStringInput bs) $ proc "lpr" $ [ "-P " <> lprServer -- queue@hostname:port ] ++ jobname ++ -- a name for job identification at printing site [ "-" -- read from stdin ] jobname | null jb = [] | otherwise = ["-J " <> jb] exit2either <$> readProcess' pc -}