lpr: link lpr calls and printJob db entries for actual printing
This commit is contained in:
Steffen Jost
parent
839b126c6a
commit
3dbdccfa7b
@ -77,7 +77,7 @@ QualificationUser
|
||||
-- + if contained:
|
||||
-- set LmsUserReceived to Just now()
|
||||
-- if LmsUserlistFailed: set LmsUserStatus to Just Day
|
||||
-- + not contianed, by LmsUserReceived is set: set LmsUserEnded to Just now()
|
||||
-- + not contained, by LmsUserReceived is set: set LmsUserEnded to Just now()
|
||||
-- - move row to LmsAudit
|
||||
--
|
||||
-- 6. When received: Daily Job LmsResult:
|
||||
|
||||
@ -313,10 +313,16 @@ postPrintSendR = do
|
||||
-- liftIO $ LBS.writeFile "/tmp/generated.pdf" bs -- DEBUGGING ONLY
|
||||
-- addMessage Warning "PDF momentan nur gespeicher unter /tmp/generated.pdf"
|
||||
uID <- maybeAuthId
|
||||
filepath <- runDB $ sendLetter "Test-Brief" bs mbRecipient uID Nothing Nothing
|
||||
addMessage Success $ toHtml $ "Druckauftrag angelegt: " <> filepath
|
||||
-- TODO: continue here with acutal letter sending!
|
||||
pure True
|
||||
runDB (sendLetter "Test-Brief" bs mbRecipient uID Nothing Nothing) >>= \case -- calls lpr
|
||||
Left err -> do
|
||||
let msg = "PDF printing failed with error: " <> err
|
||||
$logErrorS "LPR" msg
|
||||
addMessage Error $ toHtml msg
|
||||
pure False
|
||||
Right (ok, fpath) -> do
|
||||
let response = if null ok then mempty else " Response: " <> ok
|
||||
addMessage Success $ toHtml $ "Druckauftrag angelegt: " <> pack fpath <> response
|
||||
pure True
|
||||
(Nothing, Left err) -> do
|
||||
addMessage Error $ toHtml err
|
||||
pure False
|
||||
|
||||
@ -50,7 +50,7 @@ dispatchNotificationQualificationRenewal nQualification jRecipient = do
|
||||
<*> getJustBy (UniqueQualificationUser nQualification jRecipient)
|
||||
let qname = CI.original qualificationName
|
||||
-- content = $(i18nWidgetFile "qualification/renewal")
|
||||
$logDebugS "LMS" $ "Notify " <> tshow jRecipient <> " for renewal of qualifiaction " <> qname
|
||||
$logDebugS "LMS" $ "Notify " <> tshow jRecipient <> " for renewal of qualification " <> qname
|
||||
|
||||
let pdfMeta = applyMetas
|
||||
[ ("recipient", userDisplayName)
|
||||
@ -85,11 +85,14 @@ dispatchNotificationQualificationRenewal nQualification jRecipient = do
|
||||
addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/qualificationRenewal.hamlet")
|
||||
|
||||
Right pdf | otherwise -> do
|
||||
let printJobName = mempty --TODO
|
||||
lprPDF printJobName pdf >>= \case
|
||||
let printJobName = mempty --TODO
|
||||
printSender = Nothing --TODO
|
||||
runDB (sendLetter printJobName pdf printSender (Just jRecipient) Nothing (Just nQualification)) >>= \case
|
||||
-- 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
|
||||
Right (msg,_)
|
||||
| null msg -> return ()
|
||||
| otherwise -> $logWarnS "LMS" $ "PDF printing to send letter with lpr returned ExitSucces and the following message: " <> msg
|
||||
@ -230,7 +230,7 @@ pdfRenewal' meta = do
|
||||
-- PrintJobs --
|
||||
---------------
|
||||
|
||||
sendLetter :: Text -> LBS.ByteString -> Maybe UserId -> Maybe UserId -> Maybe CourseId -> Maybe QualificationId -> DB FilePath
|
||||
sendLetter :: Text -> LBS.ByteString -> Maybe UserId -> Maybe UserId -> Maybe CourseId -> Maybe QualificationId -> DB (Either Text (Text, FilePath))
|
||||
sendLetter printJobName pdf printJobRecipient printJobSender printJobCourse printJobQualification = do
|
||||
recipient <- join <$> mapM get printJobRecipient
|
||||
sender <- join <$> mapM get printJobSender
|
||||
@ -241,14 +241,19 @@ sendLetter printJobName pdf printJobRecipient printJobSender printJobCourse prin
|
||||
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"
|
||||
jobFullName = unpack $ T.replace " " "-" (T.intercalate "_" . catMaybes $ [Just printJobName, nameQuali, nameCourse, nameSender, nameRecipient])
|
||||
printJobFilename = jobFullName <> ".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 printJobFilename
|
||||
printJobFile = LBS.toStrict pdf
|
||||
lprPDF jobFullName pdf >>= \case
|
||||
Left err -> do
|
||||
return $ Left err
|
||||
Right ok -> do
|
||||
printJobCreated <- liftIO getCurrentTime
|
||||
insert_ PrintJob {..}
|
||||
return $ Right (ok, 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
|
||||
@ -260,17 +265,18 @@ sendLetter' printJobName pdf printJobRecipient printJobSender printJobCourse pri
|
||||
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"
|
||||
jobFullName = unpack $ T.replace " " "-" (T.intercalate "_" . catMaybes $ [Just printJobName, nameQuali, nameCourse, nameSender, nameRecipient])
|
||||
printJobFilename = jobFullName <> ".pdf"
|
||||
-- printJobFile <- sinkFileDB True $ yield $ LBS.toStrict pdf -- for PrintJobFile :: FileContentReference use this code
|
||||
printJobFile = LBS.toStrict pdf
|
||||
-- TODO: system call to lpr here!
|
||||
printJobFile = LBS.toStrict pdf
|
||||
lprPDF jobFullName pdf
|
||||
printJobCreated <- liftIO getCurrentTime
|
||||
insert_ PrintJob {..}
|
||||
return $ File { fileTitle = printJobFilename
|
||||
, fileModified = printJobCreated
|
||||
, fileContent = Just $ yield printJobFile
|
||||
}
|
||||
|
||||
-}
|
||||
|
||||
-----------------------------
|
||||
-- Typed Process Utilities --
|
||||
@ -329,6 +335,10 @@ encryptPDF pw bs = over _Left (decodeUtf8 . LBS.toStrict) . exit2either <$> read
|
||||
-- The cups version of lpr is instead used like so:
|
||||
-- > lpr -P fradrive -H fravm017173.fra.fraport.de:515 -T printJobName -
|
||||
|
||||
|
||||
-- TODO: consider hiding this function within the export, as it does not create an entry in the printJob table in the DB
|
||||
|
||||
-- | Internal, use `sendLetter` instead
|
||||
lprPDF :: (MonadHandler m, HasAppSettings (HandlerSite m)) => String -> LBS.ByteString -> m (Either Text Text)
|
||||
lprPDF jb bs = do
|
||||
lprServerArg <- $cachedHereBinary ("lprServer"::Text) getLprServerArg
|
||||
|
||||
Loading…
Reference in New Issue
Block a user