504 lines
24 KiB
Haskell
504 lines
24 KiB
Haskell
-- SPDX-FileCopyrightText: 2022-23 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
|
|
( 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
|
|
-}
|