fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

chore(lms): email notifications send encrypted pdfs now

Browse Source
This commit is contained in:
Steffen Jost 2022-07-25 18:16:08 +02:00
parent 56c2847b45
commit 33f133b5de
6 changed files with 79 additions and 31 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
messages/uniworx/categories/print/de-de-formal.msg
View File

@ -1,5 +1,6 @@
PJActAcknowledge: Druck und Versand bestätigen
PrintJobName: Bezeichnung
PrintJobFilename: Dateiname
PrintJobId !ident-ok: Id
PrintJobCreated: Gesendet
PrintJobAcknowledged: Bestätigt

1
messages/uniworx/categories/print/en-eu.msg
View File

@ -1,5 +1,6 @@
PJActAcknowledge: Acknowledge printing and mailing
PrintJobName: Description
PrintJobFilename: Filename
PrintJobId: Id
PrintJobCreated: Created
PrintJobAcknowledged: Acknowledged

2
src/Handler/Admin/Test.hs
View File

@ -306,7 +306,7 @@ getAdminTestPdfR = do
liftIO $ LBS.writeFile "/tmp/generated.pdf" bs
mbEncPdf <- encryptPDF "tomatenmarmelade" bs
case mbEncPdf of
Left err -> sendResponseStatus internalServerError500 $ decodeUtf8 $ LBS.toStrict $ "PDFtk error: \n" <> err
Left err -> sendResponseStatus internalServerError500 $ "PDFtk error: \n" <> err
Right encPdf -> do
liftIO $ LBS.writeFile "/tmp/crypted.pdf" encPdf
sendByteStringAsFile "demoPDF.pdf" (LBS.toStrict bs) now

12
src/Handler/PrintCenter.hs
View File

@ -202,9 +202,10 @@ mkPJTable = do
[ dbSelectIf (applying _2) id (return . view (resultPrintJob . _entityKey)) (\r -> isNothing $ r ^. resultPrintJob . _entityVal . _printJobAcknowledged)
, sortable (Just "pj-created") (i18nCell MsgPrintJobCreated) $ \( view $ resultPrintJob . _entityVal . _printJobCreated -> t) -> dateTimeCell t
, sortable (Just "pj-acknowledged") (i18nCell MsgPrintJobAcknowledged) $ \( view $ resultPrintJob . _entityVal . _printJobAcknowledged -> t) -> maybeDateTimeCell t
, sortable (Just "pj-filename") (i18nCell MsgPrintJobFilename) $ \( view $ resultPrintJob . _entityVal . _printJobFilename -> t) -> textCell t
, sortable (toNothingS "pdf") (i18nCell MsgPrintPDF) $ \( view $ resultPrintJob . _entityKey -> k) -> anchorCellM (PrintDownloadR <$> encrypt k) (showId k)
-- , sortable (Just "pj-id") (i18nCell MsgPrintJobId) $ \( view $ resultPrintJob . _entityKey -> k) -> textCell (tshow . E.unSqlBackendKey $ unPrintJobKey k)
-- , sortable (Just "pj-id") (i18nCell MsgPrintJobId) $ \( view $ resultPrintJob . _entityKey -> k) -> cell (showId k)
-- , sortable (Just "pj-id") (i18nCell MsgPrintJobId) $ \( view $ resultPrintJob . _entityKey -> k) -> cell (showId k)
, sortable (Just "pj-name") (i18nCell MsgPrintJobName) $ \( view $ resultPrintJob . _entityVal . _printJobName -> n) -> textCell n
, sortable (Just "pj-recipient") (i18nCell MsgPrintRecipient) $ \(preview resultRecipient -> u) -> maybeCell u $ cellHasUserLink AdminUserR
, sortable (Just "pj-sender") (i18nCell MsgPrintSender) $ \(preview resultSender -> u) -> maybeCell u $ cellHasUserLink AdminUserR
@ -213,6 +214,7 @@ mkPJTable = do
]
dbtSorting = mconcat
[ single ("pj-name" , SortColumn $ queryPrintJob >>> (E.^. PrintJobName))
, single ("pj-filename" , SortColumn $ queryPrintJob >>> (E.^. PrintJobFilename))
-- , single ("pj-id" , SortColumn $ queryPrintJob >>> (E.^. PrintJobId))
, single ("pj-created" , SortColumn $ queryPrintJob >>> (E.^. PrintJobCreated))
, single ("pj-acknowledged" , SortColumn $ queryPrintJob >>> (E.^. PrintJobAcknowledged))
@ -223,6 +225,7 @@ mkPJTable = do
]
dbtFilter = mconcat
[ single ("pj-name" , FilterColumn . E.mkContainsFilter $ views (to queryPrintJob) (E.^. PrintJobName))
, single ("pj-filename" , FilterColumn . E.mkContainsFilter $ views (to queryPrintJob) (E.^. PrintJobFilename))
, single ("pj-recipient" , FilterColumn . E.mkContainsFilterWith Just $ views (to queryRecipient) (E.?. UserDisplayName))
, single ("pj-sender" , FilterColumn . E.mkContainsFilterWith Just $ views (to querySender) (E.?. UserDisplayName))
, single ("pj-course" , FilterColumn . E.mkContainsFilterWith Just $ views (to queryCourse) (E.?. CourseName))
@ -230,7 +233,8 @@ mkPJTable = do
, single ("acknowledged" , FilterColumn . E.mkExactFilterLast $ views (to queryPrintJob) (E.isJust . (E.^. PrintJobAcknowledged)))
]
dbtFilterUI mPrev = mconcat
[ prismAForm (singletonFilter "pj-name" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintJobName)
[ prismAForm (singletonFilter "pj-filename" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintJobFilename)
, prismAForm (singletonFilter "pj-name" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintJobName)
, prismAForm (singletonFilter "pj-recipient" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintRecipient)
, prismAForm (singletonFilter "pj-sender" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintSender)
, prismAForm (singletonFilter "pj-course" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintCourse)
@ -314,10 +318,10 @@ postPrintSendR = do
-- TODO: continue here with acutal letter sending!
pure True
(Nothing, Left err) -> do
addMessage Error . toHtml $ P.renderError err
addMessage Error $ toHtml err
pure False
(Just uid, Left err) -> do
addMessage Error . toHtml $ "For uid " <> tshow uid <> ": " <> P.renderError err
addMessage Error . toHtml $ "For uid " <> tshow uid <> ": " <> err
pure False
when (or oks) $ redirect PrintCenterR
formResult sendResult procFormSend

49
src/Jobs/Handler/SendNotification/Qualification.hs
View File

@ -7,10 +7,12 @@ module Jobs.Handler.SendNotification.Qualification
import Import
import Utils.Print
import Handler.Utils
import Jobs.Handler.SendNotification.Utils
import qualified Data.ByteString.Lazy as LBS
-- import Handler.Info (FAQItem(..))
import qualified Data.CaseInsensitive as CI
import Text.Hamlet
@ -30,41 +32,56 @@ dispatchNotificationQualificationExpiry nQualification _nExpiry jRecipient = use
$logDebugS "LMS" $ "Notify " <> tshow jRecipient <> " about expiry of qualification " <> qname
replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
setSubjectI $ MsgMailSubjectQualificationExpiry qname
editNotifications <- mkEditNotifications jRecipient
addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/qualificationExpiry.hamlet")
checkEmailOk :: a -> Bool
checkEmailOk = const True -- TODO
checkEmailOk = const True -- TODO
dispatchNotificationQualificationRenewal :: QualificationId -> UserId -> Handler ()
dispatchNotificationQualificationRenewal nQualification jRecipient = do
dispatchNotificationQualificationRenewal nQualification jRecipient = do
(User{..}, Qualification{..}, Entity _ QualificationUser{..}) <- runDB $ (,,)
<$> getJust jRecipient
<*> getJust nQualification
<*> getJustBy (UniqueQualificationUser nQualification jRecipient)
let qname = CI.original qualificationName
let qname = CI.original qualificationName
-- content = $(i18nWidgetFile "qualification/renewal")
$logDebugS "LMS" $ "Notify " <> tshow jRecipient <> " for renewal of qualifiaction " <> qname
if | checkEmailOk userEmail -> userMailT jRecipient $ do
let pdfMeta = applyMetas [("recipient", userDisplayName)] mempty -- TODO: add more info to interpolate here!
pdfRenewal pdfMeta >>= \case
Left err -> do
let msg = "Notify " <> tshow jRecipient <> " PDF generation failed with error: " <> err
$logErrorS "LMS" msg
error $ unpack msg
Right pdf | checkEmailOk userEmail -> userMailT jRecipient $ do
replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
setSubjectI $ MsgMailSubjectQualificationRenewal qname
editNotifications <- mkEditNotifications jRecipient -- TODO: add to hamlet file again
editNotifications <- mkEditNotifications jRecipient -- TODO: add to hamlet file again
-- let msgrenewal = $(i18nHamletFile "qualification/renewal") -- :: HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX)
-- addHtmlMarkdownAlternatives' msgrenewal
-- TODO: this is just a dummy to continue while i18nHamletFile usage is unclear
addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/qualificationRenewal.hamlet")
now <- liftIO getCurrentTime
encryptPDF "tomatenmarmelade" pdf >>= \case
Left err -> do
let msg = "Notify " <> tshow jRecipient <> " PDF encryption failed with error: " <> err
$logErrorS "LMS" msg
error $ unpack msg
Right pdffile -> do
addPart (File { fileTitle = "Renewal Pin Letter"
, fileModified = now
, fileContent = Just $ yield $ LBS.toStrict pdffile
} :: PureFile)
-- TODO: this is just a dummy to continue while i18nHamletFile usage is unclear
addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/qualificationRenewal.hamlet")
| otherwise -> do
Right _pdf | otherwise -> do
let _letterHead = error "TODO"
-- makePDF "pdflatex" [] writer woptions pandoc
-- makePDF "pdflatex" [] writer woptions pandoc
error "TODO"

45
src/Utils/Print.hs
View File

@ -207,15 +207,16 @@ mdRenewal meta = runExceptT $ do
, P.writerTemplate = Just tmpl
}
ExceptT . pure . P.runPure $ P.writeMarkdown writerOpts $ appMeta setIsDeFromLang
$ addMeta meta doc
$ addMeta meta doc
-- | combines 'mdRenewal' and 'pdfDIN5008'
pdfRenewal :: P.Meta -> HandlerFor UniWorX (Either P.PandocError LBS.ByteString)
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
actRight e_txt $ pdfDIN5008 meta
result <- actRight e_txt $ pdfDIN5008 meta
return $ over _Left P.renderError result
-- | like pdfRenewal but without caching
pdfRenewal' :: P.Meta -> P.PandocIO LBS.ByteString
@ -240,7 +241,7 @@ sendLetter printJobName pdf printJobRecipient printJobSender printJobCourse prin
nameCourse = CI.original . courseShorthand <$> course
nameQuali = CI.original . qualificationShorthand <$> quali
let printJobAcknowledged = Nothing
printJobFilename = unpack $ (T.intercalate "_" . catMaybes $ [Just printJobName, nameQuali, nameCourse, nameSender, nameRecipient]) <> ".pdf"
printJobFilename = unpack $ T.replace " " "-" (T.intercalate "_" . catMaybes $ [Just printJobName, nameQuali, nameCourse, nameSender, nameRecipient]) <> ".pdf"
-- printJobFile <- sinkFileDB True $ yield $ LBS.toStrict pdf -- for PrintJobFile :: FileContentReference use this code
printJobFile = LBS.toStrict pdf
-- TODO: system call to lpr here!
@ -248,6 +249,28 @@ sendLetter printJobName pdf printJobRecipient printJobSender printJobCourse prin
insert_ PrintJob {..}
return printJobFilename
sendLetter' :: Text -> LBS.ByteString -> Maybe UserId -> Maybe UserId -> Maybe CourseId -> Maybe QualificationId -> DB PureFile
sendLetter' printJobName pdf printJobRecipient printJobSender printJobCourse printJobQualification = do
recipient <- join <$> mapM get printJobRecipient
sender <- join <$> mapM get printJobSender
course <- join <$> mapM get printJobCourse
quali <- join <$> mapM get printJobQualification
let nameRecipient = userDisplayName <$> recipient
nameSender = userDisplayName <$> sender
nameCourse = CI.original . courseShorthand <$> course
nameQuali = CI.original . qualificationShorthand <$> quali
let printJobAcknowledged = Nothing
printJobFilename = unpack $ T.replace " " "-" (T.intercalate "_" . catMaybes $ [Just printJobName, nameQuali, nameCourse, nameSender, nameRecipient]) <> ".pdf"
-- printJobFile <- sinkFileDB True $ yield $ LBS.toStrict pdf -- for PrintJobFile :: FileContentReference use this code
printJobFile = LBS.toStrict pdf
-- TODO: system call to lpr here!
printJobCreated <- liftIO getCurrentTime
insert_ PrintJob {..}
return $ File { fileTitle = printJobFilename
, fileModified = printJobCreated
, fileContent = Just $ yield printJobFile
}
-----------
-- pdftk --
@ -259,17 +282,19 @@ sendLetter printJobName pdf printJobRecipient printJobSender printJobCourse prin
-- > pdftk - output - user_pw tomatenmarmelade
--
encryptPDF :: MonadIO m => String -> LBS.ByteString -> m (Either LBS.ByteString LBS.ByteString)
encryptPDF pw bs = exit2either <$> readProcess pc
encryptPDF :: MonadIO m => String -> LBS.ByteString -> m (Either Text LBS.ByteString)
encryptPDF pw bs = over _Left (decodeUtf8 . LBS.toStrict) . exit2either <$> readProcess pc
where
pc = setStdin (byteStringInput bs) $
proc "pdftk" ["-" -- read from stdin
proc "pdftk" [ "-" -- read from stdin
, "output", "-" -- write to stdout
, "user_pw", 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.
exit2either :: (ExitCode, a, b) -> Either b a
exit2either (ExitSuccess , ok, _) = Right ok
exit2either (ExitFailure _ , _, err) = Left err
exit2either (ExitSuccess , ok, _) = Right ok -- warnings are ignored here!
exit2either (ExitFailure _ , _, err) = Left err