diff --git a/src/Handler/Course/Users.hs b/src/Handler/Course/Users.hs index 37cb6ee00..d44805f8f 100644 --- a/src/Handler/Course/Users.hs +++ b/src/Handler/Course/Users.hs @@ -513,7 +513,7 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do , dbParamsFormResult = id , dbParamsFormIdent = def } - dbtCsvName = MsgCourseUserCsvName courseTerm courseSchool courseShorthand + dbtCsvName = MsgCourseUserCsvName courseTerm courseSchool courseShorthand dbtCsvSheetName = MsgCourseUserCsvSheetName courseTerm courseSchool courseShorthand dbtCsvEncode = do csvColumns' <- csvColumns diff --git a/src/Jobs/Handler/SendNotification/Qualification.hs b/src/Jobs/Handler/SendNotification/Qualification.hs index 8de1e0254..fc3b72d21 100644 --- a/src/Jobs/Handler/SendNotification/Qualification.hs +++ b/src/Jobs/Handler/SendNotification/Qualification.hs @@ -52,7 +52,10 @@ dispatchNotificationQualificationRenewal nQualification jRecipient = do -- content = $(i18nWidgetFile "qualification/renewal") $logDebugS "LMS" $ "Notify " <> tshow jRecipient <> " for renewal of qualifiaction " <> qname - let pdfMeta = applyMetas [("recipient", userDisplayName)] mempty -- TODO: add more info to interpolate here! + let pdfMeta = applyMetas + [ ("recipient", userDisplayName) + -- TODO: add more info to interpolate here! + ] mempty pdfRenewal pdfMeta >>= \case Left err -> do let msg = "Notify " <> tshow jRecipient <> " PDF generation failed with error: " <> err @@ -81,7 +84,12 @@ dispatchNotificationQualificationRenewal nQualification jRecipient = do -- TODO: this is just a dummy to continue while i18nHamletFile usage is unclear addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/qualificationRenewal.hamlet") - Right _pdf | otherwise -> do - let _letterHead = error "TODO" - -- makePDF "pdflatex" [] writer woptions pandoc - error "TODO" + Right pdf | otherwise -> do + let printJobName = mempty --TODO + lprPDF printJobName pdf >>= \case + Left err -> do + let msg = "Notify " <> tshow jRecipient <> " PDF printing to send letter failed with error: " <> err + $logErrorS "LMS" msg + error $ unpack msg + Right msg | null msg -> return () + | otherwise -> $logWarnS "LMS" $ "PDF printing to send letter with lpr returned ExitSucces and the following message: " <> msg \ No newline at end of file diff --git a/src/Utils/Print.hs b/src/Utils/Print.hs index 375d522c5..eec40cbcb 100644 --- a/src/Utils/Print.hs +++ b/src/Utils/Print.hs @@ -19,9 +19,9 @@ import System.Process.Typed -- for calling pdftk for pdf encryption -- import Model.Types.Markup -- TODO-QSV: should this module be moved accordingly? -{- Recall: +{- Recall: Funktionen außerhalb der Hanlder-Monade gehören in Utils-Module; - ansonsten drohen zyklische Abhängikeiten, d.h. + ansonsten drohen zyklische Abhängikeiten, d.h. ggf. Funktionen in der HandlerFor-Monade nach Handler.Utils.Print verschieben! -} @@ -63,8 +63,8 @@ makePDF wopts doc = do bs2pandocError = over _Left (P.PandocMakePDFError . decodeUtf8 . LBS.toStrict) _Meta :: Lens' P.Pandoc P.Meta -_Meta = lens mget mput - where +_Meta = lens mget mput + where mget (P.Pandoc m _) = m mput (P.Pandoc _ b) m = P.Pandoc m b @@ -96,7 +96,7 @@ setIsDeFromLang m isde = "is-de" defReaderOpts :: P.ReaderOptions -defReaderOpts = def { P.readerExtensions = P.pandocExtensions, P.readerStripComments = True } +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 } @@ -113,7 +113,7 @@ defWriterOpts t = def { P.writerExtensions = P.pandocExtensions, P.writerTemplat -- 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 + tmpl <- compileTemplate strictMarkupInput doc <- areader readerOpts strictMarkupInput let writerOpts = def { P.writerExtensions = P.pandocExtensions , P.writerTemplate = Just tmpl } @@ -143,7 +143,7 @@ reTemplateLetter' meta md = do where readerOpts = def { P.readerExtensions = P.pandocExtensions , P.readerStripComments = True - } + } --pdfDIN5008 :: P.PandocMonad m => Text -> m LBS.ByteString -- for pandoc > 2.18 @@ -179,25 +179,25 @@ pdfDIN5008 meta md = do -- | like 'reTemplateLetter' but uses 'templateRenewal' and caches the result mdRenewal' :: P.Meta -> HandlerFor UniWorX (Either P.PandocError Text) -mdRenewal' meta = do +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 + 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 + , 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 +mdRenewal meta = runExceptT $ do let readerOpts = def { P.readerExtensions = P.pandocExtensions , P.readerStripComments = True } @@ -207,22 +207,22 @@ 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 Text LBS.ByteString) pdfRenewal meta = do - e_txt <- mdRenewal' meta + 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 +pdfRenewal' meta = do + doc <- reTemplateLetter' meta templateRenewal + pdfDIN5008' meta doc @@ -231,14 +231,14 @@ pdfRenewal' meta = do --------------- sendLetter :: Text -> LBS.ByteString -> Maybe UserId -> Maybe UserId -> Maybe CourseId -> Maybe QualificationId -> DB FilePath -sendLetter printJobName pdf printJobRecipient printJobSender printJobCourse printJobQualification = do +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 + 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" @@ -250,14 +250,14 @@ sendLetter printJobName pdf printJobRecipient printJobSender printJobCourse prin return printJobFilename sendLetter' :: Text -> LBS.ByteString -> Maybe UserId -> Maybe UserId -> Maybe CourseId -> Maybe QualificationId -> DB PureFile -sendLetter' printJobName pdf printJobRecipient printJobSender printJobCourse printJobQualification = do +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 + 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" @@ -269,7 +269,20 @@ sendLetter' printJobName pdf printJobRecipient printJobSender printJobCourse pri return $ File { fileTitle = printJobFilename , fileModified = printJobCreated , fileContent = Just $ yield printJobFile - } + } + + +----------------------------- +-- 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 ususally might contain warning messages. +-- To be used with 'System.Process.Typed.readProcess' +exit2either :: (ExitCode, a, b) -> Either b a +exit2either (ExitSuccess , ok, _) = Right ok -- warnings are ignored here! +exit2either (ExitFailure _ , _, err) = Left err + ----------- @@ -284,7 +297,7 @@ sendLetter' printJobName pdf printJobRecipient printJobSender printJobCourse pri encryptPDF :: MonadIO m => String -> LBS.ByteString -> m (Either Text LBS.ByteString) encryptPDF pw bs = over _Left (decodeUtf8 . LBS.toStrict) . exit2either <$> readProcess pc - where + where pc = setStdin (byteStringInput bs) $ proc "pdftk" [ "-" -- read from stdin , "output", "-" -- write to stdout @@ -295,6 +308,26 @@ encryptPDF pw bs = over _Left (decodeUtf8 . LBS.toStrict) . exit2either <$> read -- 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 -- warnings are ignored here! - exit2either (ExitFailure _ , _, err) = Left err \ No newline at end of file + + + +--------- +-- 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 -J printJobName - +-- + +lprPDF :: MonadIO m => String -> LBS.ByteString -> m (Either Text Text) +lprPDF jb bs = over _Left (decodeUtf8 . LBS.toStrict) . + over _Right (decodeUtf8 . LBS.toStrict) . exit2either <$> readProcess pc + where + pc = setStdin (byteStringInput bs) $ + proc "lpr" $ [ "-P fradrive@fravm017173.fra.fraport.de:515" -- queue@hostname:port TODO: turn this into a setting + ] ++ jobname ++ -- a name for job identification at printing site + [ "-" -- read from stdin + ] + jobname | null jb = [] + | otherwise = ["-J", jb]