diff --git a/messages/uniworx/categories/print/de-de-formal.msg b/messages/uniworx/categories/print/de-de-formal.msg index 2327b2661..4d1613955 100644 --- a/messages/uniworx/categories/print/de-de-formal.msg +++ b/messages/uniworx/categories/print/de-de-formal.msg @@ -1,5 +1,6 @@ PJActAcknowledge: Druck und Versand bestätigen PrintJobName: Bezeichnung +PrintJobFilename: Dateiname PrintJobId !ident-ok: Id PrintJobCreated: Gesendet PrintJobAcknowledged: Bestätigt diff --git a/messages/uniworx/categories/print/en-eu.msg b/messages/uniworx/categories/print/en-eu.msg index 97102165e..db5b04ca2 100644 --- a/messages/uniworx/categories/print/en-eu.msg +++ b/messages/uniworx/categories/print/en-eu.msg @@ -1,5 +1,6 @@ PJActAcknowledge: Acknowledge printing and mailing PrintJobName: Description +PrintJobFilename: Filename PrintJobId: Id PrintJobCreated: Created PrintJobAcknowledged: Acknowledged diff --git a/src/Handler/Admin/Test.hs b/src/Handler/Admin/Test.hs index b5a63b6d8..584715515 100644 --- a/src/Handler/Admin/Test.hs +++ b/src/Handler/Admin/Test.hs @@ -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 diff --git a/src/Handler/PrintCenter.hs b/src/Handler/PrintCenter.hs index 66f792294..3971d76dc 100644 --- a/src/Handler/PrintCenter.hs +++ b/src/Handler/PrintCenter.hs @@ -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 diff --git a/src/Jobs/Handler/SendNotification/Qualification.hs b/src/Jobs/Handler/SendNotification/Qualification.hs index 8ca116ae7..01566ebdf 100644 --- a/src/Jobs/Handler/SendNotification/Qualification.hs +++ b/src/Jobs/Handler/SendNotification/Qualification.hs @@ -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" - - \ No newline at end of file diff --git a/src/Utils/Print.hs b/src/Utils/Print.hs index 41f8709d5..7b76cf071 100644 --- a/src/Utils/Print.hs +++ b/src/Utils/Print.hs @@ -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 \ No newline at end of file + exit2either (ExitSuccess , ok, _) = Right ok -- warnings are ignored here! + exit2either (ExitFailure _ , _, err) = Left err \ No newline at end of file