-- SPDX-FileCopyrightText: 2022 Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later {-# OPTIONS_GHC -fno-warn-unused-top-binds #-} module Utils.Print ( renderLetter -- used for generating letter pdfs , sendEmailOrLetter -- directly print or sends by email , printLetter -- always send a letter , letterApcIdent -- create acknowledge string for APC , encryptPDF , sanitizeCmdArg, validCmdArgument -- , compileTemplate, makePDF , _Meta, addMeta , toMeta, mbMeta -- single values , mkMeta, appMeta, applyMetas -- multiple values , LetterRenewQualificationF(..) ) 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.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.Letters import Utils.Print.RenewQualification -- 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 P.PandocError Text) mdTemplating template meta = runExceptT $ do let readerOpts = def { P.readerExtensions = P.pandocExtensions , P.readerStripComments = True } doc <- ExceptT $ $cachedHereBinary ("pandoc: \n" <> template) (pure . P.runPure $ P.readMarkdown readerOpts template) tmpl <- ExceptT $ $cachedHereBinary ("template: \n" <> template) (pure . P.runPure $ compileTemplate template) let writerOpts = def { P.writerExtensions = P.pandocExtensions , P.writerTemplate = Just tmpl } ExceptT . pure . P.runPure $ P.writeMarkdown writerOpts $ appMeta setIsDeFromLang $ addMeta meta doc -- | 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 , P.writerTemplate = Just tmpl } doc <- P.readMarkdown readerOpts md makePDF writerOpts $ appMeta setIsDeFromLang $ addMeta meta doc 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 = addApcIdent apcIdent <> letterMeta mdl formatter lang rcvrEnt <> mkMeta [ toMeta "lang" lang , 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 result <- actRight e_md $ pdfLaTeX kind meta return $ over _Left P.renderError result --------------- -- PrintJobs -- --------------- -- 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 <- renderLetter 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 } = pji recipient <- join <$> mapM get printJobRecipient sender <- join <$> mapM get printJobSender course <- join <$> mapM get printJobCourse quali <- join <$> mapM get printJobQualification let nameRecipient = abbrvName <$> recipient nameSender = abbrvName <$> sender nameCourse = CI.original . courseShorthand <$> course nameQuali = CI.original . qualificationShorthand <$> quali let jobFullName = text2asciiAlphaNum $ T.replace " " "-" (T.intercalate "_" . catMaybes $ [Just printJobName, nameQuali, nameCourse, nameSender, nameRecipient]) printJobFilename = T.unpack $ jobFullName <> ".pdf" -- printJobFile <- sinkFileDB True $ yield $ LBS.toStrict pdf -- for PrintJobFile :: FileContentReference use this code printJobFile = LBS.toStrict pdf printJobAcknowledged = Nothing lprPDF jobFullName 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) {- 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 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 oks <- forM receivers $ \rcvrEnt@Entity{ entityKey = svr, entityVal = rcvrUsr } -> do encRecipient :: CryptoUUIDUser <- encrypt svr apcIdent <- letterApcIdent letter encRecipient now let (preferPost, postal) = getPostalPreferenceAndAddress rcvrUsr -- mailBody = getMailBody letter formatter 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 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, 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 Right pdf -> do -- send email let pdfPass = case encrypPDFfor (pure 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 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 addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/genericMailLetter.hamlet") addPart (File { fileTitle = T.unpack $ pjiName pjid <> ".pdf" , fileModified = now , fileContent = Just $ yield $ LBS.toStrict attachment } :: PureFile) 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)) -- | 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)) => Text -> LBS.ByteString -> m (Either Text Text) lprPDF jb bs = do mbLprServerArg <- $cachedHereBinary ("lprServer"::Text) getLprServerArg case mbLprServerArg of Nothing -> return $ Right "Print command ignored due to setting 'mail-reroute-to' being set." Just 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'] jb' = T.unpack $ sanitizeCmdArg jb exit2either <$> readProcess' pc where getLprServerArg = do rerouteMail <- getsYesod $ view _appMailRerouteTo case rerouteMail of Just _ -> return Nothing 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 -}