389 lines
17 KiB
Haskell
389 lines
17 KiB
Haskell
-- SPDX-FileCopyrightText: 2022 Steffen Jost <jost@tcs.ifi.lmu.de>
|
|
--
|
|
-- 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
|
|
-}
|