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

chore(lpr): call lpr in qualfication renewal message

Browse Source
This commit is contained in:
Steffen Jost 2022-07-29 16:55:22 +02:00
parent 3ac2151451
commit 4dbf5f35be
3 changed files with 74 additions and 33 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
src/Handler/Course/Users.hs
View File

@ -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

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

@ -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

87
src/Utils/Print.hs
View File

@ -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
---------
-- 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]