615 lines
26 KiB
Haskell
615 lines
26 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
|
|
( pdfRenewal
|
|
, sendLetter, sendLetter'
|
|
, sendEmailOrLetter
|
|
, encryptPDF
|
|
, sanitizeCmdArg, validCmdArgument
|
|
, templateDIN5008
|
|
, templateRenewal
|
|
-- , 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, nameHtml')
|
|
import Handler.Utils.Avs (updateReceivers)
|
|
import Jobs.Handler.SendNotification.Utils
|
|
|
|
-- 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!
|
|
-}
|
|
|
|
|
|
|
|
-------------------------
|
|
-- Hardcoded Templates --
|
|
-------------------------
|
|
|
|
templateRenewal :: Text
|
|
templateRenewal = decodeUtf8 $(Data.FileEmbed.embedFile "templates/letter/fraport_renewal.md")
|
|
|
|
templateDIN5008 :: Text
|
|
templateDIN5008 = decodeUtf8 $(Data.FileEmbed.embedFile "templates/letter/din5008.latex")
|
|
|
|
|
|
----------------------
|
|
-- Pandoc Functions --
|
|
----------------------
|
|
-- Either I don't understand how pandoc works or
|
|
-- I don't understand why these are not included
|
|
|
|
compileTemplate :: (P.PandocMonad m) => Text -> m (P.Template Text)
|
|
compileTemplate tmpl = do
|
|
let partialPath = "" -- no partials used, see Text.DocTemplates
|
|
mbTemplate <- P.runWithDefaultPartials $ P.compileTemplate partialPath tmpl
|
|
liftEither $ str2pandocError mbTemplate
|
|
where
|
|
str2pandocError = over _Left $ P.PandocTemplateError . pack
|
|
|
|
makePDF :: P.WriterOptions -> P.Pandoc -> P.PandocIO LBS.ByteString
|
|
-- makePDF :: (PandocMonad m, MonadIO m, MonadMask m) => P.WriterOptions -> P.Pandoc -> m LBS.ByteString -- only pandoc >= 2.18
|
|
makePDF wopts doc = do
|
|
mbPdf <- P.makePDF "lualatex" texopts P.writeLaTeX wopts doc
|
|
liftEither $ bs2pandocError mbPdf
|
|
where
|
|
texopts = []
|
|
bs2pandocError = over _Left (P.PandocMakePDFError . decodeUtf8 . LBS.toStrict)
|
|
|
|
_Meta :: Lens' P.Pandoc P.Meta
|
|
_Meta = lens mget mput
|
|
where
|
|
mget (P.Pandoc m _) = m
|
|
mput (P.Pandoc _ b) m = P.Pandoc m b
|
|
|
|
toMeta :: P.ToMetaValue a => Text -> a -> Map Text P.MetaValue
|
|
toMeta k = singletonMap k . P.toMetaValue
|
|
|
|
mbMeta :: P.ToMetaValue a => Text -> Maybe a -> Map Text P.MetaValue
|
|
mbMeta = foldMap . toMeta
|
|
|
|
-- | For convenience and to avoid importing Pandoc
|
|
mkMeta :: [Map Text P.MetaValue] -> P.Meta
|
|
mkMeta = P.Meta . mconcat
|
|
|
|
-- | Modify the Meta-Block of Pandoc
|
|
appMeta :: (P.Meta -> P.Meta) -> P.Pandoc -> P.Pandoc
|
|
appMeta f (P.Pandoc m bs) = P.Pandoc (f m) bs
|
|
-- appMeta f = _Meta %~ f -- lens version. Not sure this is better
|
|
|
|
|
|
-- TODO: applyMetas is inconvenient since we cannot have an instance
|
|
-- ToMetaValue a => ToMetaValue (Maybe a)
|
|
-- so apply Metas
|
|
|
|
-- For tests see module PandocSpec
|
|
applyMetas :: (P.HasMeta p, Foldable t, P.ToMetaValue a) => t (Text, Maybe a) -> p -> p
|
|
applyMetas metas doc = Fold.foldr act doc metas
|
|
where
|
|
act (k, Just v) acc | notNull k = P.setMeta k v acc
|
|
act _ acc = acc
|
|
|
|
|
|
-- | Add meta to pandoc. Existing variables will be overwritten.
|
|
-- For specification, see module PandocSpec
|
|
addMeta :: P.Meta -> P.Pandoc -> P.Pandoc
|
|
addMeta m = appMeta (<> m) -- Data.Map says: (<>) == union and union should prefer the left operand, but somehow it does not!
|
|
--addMeta m p = meta <> p
|
|
-- where meta = P.Pandoc m mempty
|
|
|
|
-- | Pandoc conditionals only test if a variable is set or isn't set.
|
|
-- Variable "is-de" will be set to True if the "lang" variable starts with "de"
|
|
-- and will be unset otherwise
|
|
setIsDeFromLang :: P.Meta -> P.Meta
|
|
setIsDeFromLang m
|
|
| (Just (P.MetaString t)) <- P.lookupMeta "lang" m
|
|
, isDe t = P.setMeta isde True m
|
|
| otherwise = P.deleteMeta isde m
|
|
where
|
|
isde = "is-de"
|
|
|
|
defReaderOpts :: P.ReaderOptions
|
|
defReaderOpts = def { P.readerExtensions = P.pandocExtensions, P.readerStripComments = True }
|
|
|
|
defWriterOpts :: P.Template Text -> P.WriterOptions
|
|
defWriterOpts t = def { P.writerExtensions = P.pandocExtensions, P.writerTemplate = Just t }
|
|
|
|
|
|
|
|
-------------------------
|
|
-- 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
|
|
}
|
|
|
|
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
|
|
|
|
--pdfDIN5008 :: P.PandocMonad m => Text -> m LBS.ByteString -- for pandoc > 2.18
|
|
pdfDIN5008' :: P.Meta -> Text -> P.PandocIO LBS.ByteString
|
|
pdfDIN5008' meta md = do
|
|
tmpl <- compileTemplate templateDIN5008
|
|
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
|
|
|
|
-- | creates a PDF using the din5008 template
|
|
pdfDIN5008 :: P.Meta -> Text -> HandlerFor UniWorX (Either P.PandocError LBS.ByteString)
|
|
pdfDIN5008 meta md = do
|
|
e_tmpl <- $cachedHereBinary ("din5008"::Text) (liftIO . P.runIO $ compileTemplate templateDIN5008)
|
|
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
|
|
|
|
|
|
|
|
-------------------------
|
|
-- Specialized Letters --
|
|
-------------------------
|
|
|
|
-- | like 'reTemplateLetter' but uses 'templateRenewal' and caches the result
|
|
mdRenewal' :: P.Meta -> HandlerFor UniWorX (Either P.PandocError Text)
|
|
mdRenewal' meta = do
|
|
let readerOpts = def { P.readerExtensions = P.pandocExtensions
|
|
, P.readerStripComments = True
|
|
}
|
|
e_doc <- $cachedHereBinary ("renewal-pandoc"::Text) (liftIO . P.runIO $ P.readMarkdown readerOpts templateRenewal)
|
|
e_tmpl <- $cachedHereBinary ("renewal-template"::Text) (liftIO . P.runIO $ compileTemplate templateRenewal)
|
|
case (e_doc, e_tmpl) of
|
|
(Left err, _) -> pure $ Left err
|
|
(_, Left err) -> pure $ Left err
|
|
(Right md_doc, Right md_tmpl) -> do
|
|
let writerOpts = def { P.writerExtensions = P.pandocExtensions
|
|
, P.writerTemplate = Just md_tmpl
|
|
}
|
|
liftIO . P.runIO $ P.writeMarkdown writerOpts $ appMeta setIsDeFromLang
|
|
$ addMeta meta md_doc
|
|
|
|
-- | like 'reTemplateLetter' but uses 'templateRenewal' and caches the result
|
|
mdRenewal :: P.Meta -> HandlerFor UniWorX (Either P.PandocError Text)
|
|
mdRenewal meta = runExceptT $ do
|
|
let readerOpts = def { P.readerExtensions = P.pandocExtensions
|
|
, P.readerStripComments = True
|
|
}
|
|
doc <- ExceptT $ $cachedHereBinary ("renewal-pandoc"::Text) (pure . P.runPure $ P.readMarkdown readerOpts templateRenewal)
|
|
tmpl <- ExceptT $ $cachedHereBinary ("renewal-template"::Text) (pure . P.runPure $ compileTemplate templateRenewal)
|
|
let writerOpts = def { P.writerExtensions = P.pandocExtensions
|
|
, P.writerTemplate = Just tmpl
|
|
}
|
|
ExceptT . pure . P.runPure $ P.writeMarkdown writerOpts $ appMeta setIsDeFromLang
|
|
$ addMeta meta doc
|
|
|
|
|
|
-- | combines 'mdRenewal' and 'pdfDIN5008'
|
|
pdfRenewal :: P.Meta -> HandlerFor UniWorX (Either Text LBS.ByteString)
|
|
pdfRenewal meta = do
|
|
e_txt <- mdRenewal' meta
|
|
--actRight e_txt (pdfDIN5008 . appMeta setIsDeFromLang . addMeta meta) -- try this
|
|
result <- actRight e_txt $ pdfDIN5008 meta
|
|
return $ over _Left P.renderError result
|
|
|
|
-- | like pdfRenewal but without caching
|
|
pdfRenewal' :: P.Meta -> P.PandocIO LBS.ByteString
|
|
pdfRenewal' meta = do
|
|
doc <- reTemplateLetter' meta templateRenewal
|
|
pdfDIN5008' meta doc
|
|
|
|
|
|
-- Generic Version
|
|
pdfLetter :: Text -> P.Meta -> HandlerFor UniWorX (Either Text LBS.ByteString)
|
|
pdfLetter md meta = do
|
|
e_txt <- mdTemplating md meta
|
|
result <- actRight e_txt $ pdfDIN5008 meta
|
|
return $ over _Left P.renderError result
|
|
|
|
|
|
---------------
|
|
-- PrintJobs --
|
|
---------------
|
|
|
|
data PrintJobIdentification = PrintJobIdentification
|
|
{ pjiName :: Text
|
|
, pjiRecipient :: Maybe UserId
|
|
, pjiSender :: Maybe UserId
|
|
, pjiCourse :: Maybe CourseId
|
|
, pjiQualification :: Maybe QualificationId
|
|
, pjiLmsUser :: Maybe LmsIdent
|
|
}
|
|
deriving (Eq, Show)
|
|
|
|
-- DEPRECATED
|
|
sendLetter' :: Text -> LBS.ByteString -> (Maybe UserId, Maybe UserId) -> Maybe CourseId -> Maybe QualificationId -> Maybe LmsIdent -> DB (Either Text (Text, FilePath))
|
|
sendLetter' printJobName pdf (printJobRecipient, printJobSender) printJobCourse printJobQualification printJobLmsUser =
|
|
sendLetter pdf PrintJobIdentification
|
|
{ pjiName = printJobName
|
|
, pjiRecipient = printJobRecipient
|
|
, pjiSender = printJobSender
|
|
, pjiCourse = printJobCourse
|
|
, pjiQualification = printJobQualification
|
|
, pjiLmsUser = printJobLmsUser
|
|
}
|
|
|
|
sendLetter :: LBS.ByteString -> PrintJobIdentification -> DB (Either Text (Text, FilePath))
|
|
sendLetter pdf PrintJobIdentification{pjiName = printJobName, pjiRecipient = printJobRecipient, pjiSender = printJobSender, pjiCourse = printJobCourse, pjiQualification = printJobQualification, pjiLmsUser = printJobLmsUser} = do
|
|
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)
|
|
|
|
{-
|
|
sendLetter'' :: _ -> DB PureFile
|
|
sendLetter'' _ = do
|
|
...
|
|
return $ File { fileTitle = printJobFilename
|
|
, fileModified = printJobCreated
|
|
, fileContent = Just $ yield printJobFile
|
|
}
|
|
-}
|
|
|
|
|
|
{- Probably not needed:}
|
|
data SomeUserTime where
|
|
SomeUserTime :: HasLocalTime t => SelDateTimeFormat -> t -> SomeUserTime
|
|
|
|
data ProtoMeta = IsMeta P.MetaValue
|
|
| IsTime SomeUserTime
|
|
|
|
convertProto :: DateTimeFormatter -> ProtoMeta -> P.MetaValue
|
|
convertProto _ (IsMeta v) = v
|
|
convertProto f (IsTime t) = P.toMetaValue $ f t
|
|
-}
|
|
|
|
class MDLetter l where
|
|
getTemplate :: Proxy l -> Text
|
|
getMailSubject :: l -> SomeMessage UniWorX -- only used if letter is sent by email as pdf attachment
|
|
getMailBody :: l -> DateTimeFormatter -> HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX) -- only used if letter is sent by email as pdf attachment
|
|
letterMeta :: l -> DateTimeFormatter -> Lang -> P.Meta
|
|
getPJId :: l -> PrintJobIdentification
|
|
|
|
data LetterRenewQualificationF = LetterRenewQualificationF
|
|
{ lmsLogin :: LmsIdent
|
|
, lmsPin :: Text
|
|
, qualHolder :: UserDisplayName
|
|
, qualHolderSN :: UserSurname
|
|
, qualExpiry :: Day
|
|
, qualId :: QualificationId
|
|
, qualName :: Text
|
|
, qualShort :: Text
|
|
, qualSchool :: SchoolId
|
|
, qualDuration :: Maybe Int
|
|
}
|
|
deriving (Eq, Show)
|
|
|
|
-- this type is specific to this letter to avoid code duplication for derived data or constants
|
|
data LetterRenewQualificationFData = LetterRenewQualificationFData { lmsUrl, lmsUrlLogin, lmsIdent :: Text }
|
|
deriving (Eq, Show)
|
|
|
|
letterRenewalQualificationFData :: LetterRenewQualificationF -> LetterRenewQualificationFData
|
|
letterRenewalQualificationFData LetterRenewQualificationF{lmsLogin} = LetterRenewQualificationFData{..}
|
|
where
|
|
lmsUrl = "https://drive.fraport.de"
|
|
lmsUrlLogin = lmsUrl <> "/?login=" <> lmsIdent
|
|
lmsIdent = getLmsIdent lmsLogin
|
|
|
|
instance MDLetter LetterRenewQualificationF where
|
|
getTemplate _ = templateRenewal
|
|
getMailSubject l = SomeMessage $ MsgMailSubjectQualificationRenewal $ qualShort l
|
|
-- getMailBody l = SomeMessage $ MsgMailBodyQualificationRenewal $ qualName l
|
|
getMailBody l@LetterRenewQualificationF{..} DateTimeFormatter{ format } =
|
|
let LetterRenewQualificationFData{..} = letterRenewalQualificationFData l
|
|
in $(ihamletFile "templates/mail/body/qualificationRenewal.hamlet")
|
|
|
|
letterMeta l@LetterRenewQualificationF{..} DateTimeFormatter{ format } _lang =
|
|
let LetterRenewQualificationFData{..} = letterRenewalQualificationFData l
|
|
in mkMeta
|
|
[ toMeta "login" lmsIdent
|
|
, toMeta "pin" lmsPin
|
|
, toMeta "examinee" qualHolder
|
|
, toMeta "expiry" (format SelFormatDate qualExpiry)
|
|
, mbMeta "validduration" (show <$> qualDuration)
|
|
, toMeta "url-text" lmsUrl
|
|
, toMeta "url" lmsUrlLogin
|
|
]
|
|
|
|
getPJId LetterRenewQualificationF{..} =
|
|
PrintJobIdentification
|
|
{ pjiName = "Renewal"
|
|
, pjiRecipient = Nothing -- to be filled later
|
|
, pjiSender = Nothing
|
|
, pjiCourse = Nothing
|
|
, pjiQualification = Just qualId
|
|
, pjiLmsUser = Just lmsLogin
|
|
}
|
|
|
|
sendEmailOrLetter :: (MDLetter l) => UserId -> l -> Handler Bool
|
|
sendEmailOrLetter recipient letter = do
|
|
(underling, receivers, undercopy) <- updateReceivers recipient -- TODO: check to avoid this almost circular dependency
|
|
let tmpl = getTemplate $ pure letter
|
|
pjid = getPJId letter
|
|
-- Below are only needed if sent by email
|
|
mailSubject = getMailSubject letter
|
|
undername = underling ^. _userDisplayName -- nameHtml' underling
|
|
undermail = CI.original $ underling ^. _userEmail
|
|
now <- liftIO getCurrentTime
|
|
oks <- forM receivers $ \Entity{ entityKey = svr, entityVal = rcvrUsr } -> do
|
|
formatter@DateTimeFormatter{ format } <- getDateTimeFormatterUser' rcvrUsr
|
|
let (preferPost, postal) = getPostalPreferenceAndAddress rcvrUsr
|
|
isSupervised = recipient /= svr
|
|
lang = selectDeEn $ rcvrUsr & userLanguages -- select either German or English only, default de; see Utils.Lang
|
|
mailBody = getMailBody letter formatter
|
|
lMeta = letterMeta letter formatter lang <> mkMeta (
|
|
( if isSupervised
|
|
then
|
|
[ toMeta "supervisor" (rcvrUsr & userDisplayName)
|
|
, toMeta "de-opening" ("Sehr geehrte Damen und Herren,"::Text)
|
|
, toMeta "en-opening" ("Dear Sir or Madam,"::Text)
|
|
]
|
|
else []
|
|
) <>
|
|
[ toMeta "lang" lang
|
|
, toMeta "date" $ format SelFormatDate now
|
|
, toMeta "address" $ fromMaybe [rcvrUsr & userDisplayName] postal
|
|
]
|
|
)
|
|
|
|
pdfLetter tmpl lMeta >>= \case
|
|
_ | preferPost, isNothing postal -> do -- neither email nor postal is known
|
|
encRecipient :: CryptoUUIDUser <- encrypt svr
|
|
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
|
|
encRecipient :: CryptoUUIDUser <- encrypt svr
|
|
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 (sendLetter pdf pjid{ pjiRecipient = Just svr}) >>= \case
|
|
Left err -> do
|
|
encRecipient :: CryptoUUIDUser <- encrypt svr
|
|
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
|
|
attachment <- case userPinPassword rcvrUsr of
|
|
Nothing -> return pdf
|
|
Just passwd -> encryptPDF passwd pdf >>= \case
|
|
Right encPdf -> return encPdf
|
|
Left err -> do
|
|
encRecipient :: CryptoUUIDUser <- encrypt svr
|
|
let msg = "Notification for " <> tshow encRecipient <> " has unencrypted attachment. Encrypting PDF failed: " <> cropText err
|
|
$logWarnS "LETTER" msg
|
|
return pdf
|
|
userMailTdirect svr $ do
|
|
replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
|
|
setSubjectI mailSubject
|
|
editNotifications <- mkEditNotifications svr
|
|
let supername = rcvrUsr ^. _userDisplayName -- nameHtml' rcvrUsr
|
|
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 `sendLetter` 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
|
|
-}
|