-- 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 , renderLetters , sendEmailOrLetter -- directly print or sends by email , printLetter -- always send a letter , 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 , LetterRenewQualificationF(..) -- , 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.RenewQualification 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 P.readMarkdown readerOpts md_txt -- | 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 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 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 -- return $ over _Left P.renderError result -- 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 $ pure 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{} -> pure err Right doc2 -> pure $ 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 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 , 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) {- printLetter'' :: _ -> DB PureFile printLetter'' _ = do ... return $ File { fileTitle = printJobFilename , fileModified = printJobCreated , fileContent = Just $ yield printJobFile } -} sendEmailOrLetter :: (MDLetter l, MDMail 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 fName = letterFileName 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 = fName , 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)) 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 (sanitizeCmdArg' -> jb) bs = do mbLprServerArg <- 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] 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 -}