chore(aps): direct route for automatic print job acknowledging
This commit is contained in:
Steffen Jost
parent
f0531ba0b0
commit
e485f2e697
@ -12,6 +12,6 @@ PrintJob
|
||||
sender UserId Maybe OnDeleteSetNull OnUpdateCascade -- senders and associations are optional
|
||||
course CourseId Maybe OnDeleteCascade OnUpdateCascade
|
||||
qualification QualificationId Maybe OnDeleteCascade OnUpdateCascade
|
||||
lmsUser LmsUserId Maybe OnDeleteCascade OnUpdateCascade -- allows tracking if recipient has been notified; must be unique
|
||||
-- UniquePrintJobLmsUser lmsUser
|
||||
lmsUser LmsIdent Maybe OnDeleteCascade OnUpdateCascade -- allows tracking if recipient has been notified; must be unique
|
||||
-- UniquePrintJobLmsUser lmsUser -- Note that in fact multiple print jobs per LMS user are possible!
|
||||
deriving Generic
|
||||
8
routes
8
routes
@ -14,7 +14,7 @@
|
||||
-- Admins always have access to entities within their assigned schools.
|
||||
--
|
||||
-- Access tags are defined in Model.Types.Security
|
||||
--
|
||||
--
|
||||
-- Access Tags:
|
||||
-- !free -- free for all
|
||||
-- !lecturer -- lecturer for this course (or for any school, if route is not connected to a course)
|
||||
@ -66,10 +66,12 @@
|
||||
/admin/tokens AdminTokensR GET POST
|
||||
/admin/crontab AdminCrontabR GET
|
||||
/admin/avs AdminAvsR GET POST
|
||||
/admin/ldap AdminLdapR GET POST
|
||||
/admin/ldap AdminLdapR GET POST
|
||||
|
||||
/print PrintCenterR GET POST !system-printer
|
||||
/print/acknowledge/#Day/#Int/#Int PrintAcknowR GET POST !system-printer
|
||||
/print/acknowledge/#Day/#Int/#Int PrintAckR GET POST !system-printer
|
||||
/print/acknowledge/direct PrintAckDirectR POST !system-printer
|
||||
/print/acknowledge/free/direct PrintAckFreeR POST !development
|
||||
/print/send PrintSendR GET POST
|
||||
/print/download/#CryptoUUIDPrintJob PrintDownloadR GET !system-printer
|
||||
|
||||
|
||||
@ -118,7 +118,9 @@ breadcrumb AdminLdapR = i18nCrumb MsgMenuLdap $ Just AdminR
|
||||
breadcrumb PrintCenterR = i18nCrumb MsgMenuApc Nothing
|
||||
breadcrumb PrintSendR = i18nCrumb MsgMenuPrintSend $ Just PrintCenterR
|
||||
breadcrumb PrintDownloadR{} = i18nCrumb MsgMenuPrintDownload $ Just PrintCenterR
|
||||
breadcrumb PrintAcknowR{} = i18nCrumb MsgMenuPrintSend $ Just PrintCenterR
|
||||
breadcrumb PrintAckR{} = i18nCrumb MsgMenuPrintSend $ Just PrintCenterR -- never displayed
|
||||
breadcrumb PrintAckDirectR{}= i18nCrumb MsgMenuPrintSend $ Just PrintCenterR -- never displayed
|
||||
breadcrumb PrintAckFreeR{} = i18nCrumb MsgMenuPrintSend $ Just PrintCenterR -- never displayed
|
||||
|
||||
breadcrumb SchoolListR = i18nCrumb MsgMenuSchoolList $ Just AdminR
|
||||
breadcrumb (SchoolR ssh sRoute) = case sRoute of
|
||||
@ -2536,7 +2538,7 @@ pageActions PrintCenterR = do
|
||||
return NavPageActionPrimary
|
||||
{ navLink = NavLink
|
||||
{ navLabel = SomeMessage msg
|
||||
, navRoute = PrintAcknowR d n h
|
||||
, navRoute = PrintAckR d n h
|
||||
, navAccess' = NavAccessTrue
|
||||
, navType = NavTypeLink { navModal = True }
|
||||
, navQuick' = mempty
|
||||
|
||||
@ -195,7 +195,7 @@ data LmsTableCsv = LmsTableCsv -- L..T..C.. -> ltc..
|
||||
makeLenses_ ''LmsTableCsv
|
||||
|
||||
ltcExample :: LmsTableCsv
|
||||
ltcExample = LmsTableCsv
|
||||
ltcExample = LmsTableCsv
|
||||
{ ltcDisplayName = "Max Mustermann"
|
||||
, ltcEmail = "m.mustermann@does.not.exist"
|
||||
, ltcValidUntil = compDay
|
||||
@ -210,10 +210,10 @@ ltcExample = LmsTableCsv
|
||||
, ltcLmsNotified = Nothing
|
||||
, ltcLmsEnded = Nothing
|
||||
}
|
||||
where
|
||||
where
|
||||
compTime :: UTCTime
|
||||
compTime = $compileTime
|
||||
compDay :: Day
|
||||
compDay :: Day
|
||||
compDay = utctDay compTime
|
||||
|
||||
ltcOptions :: Csv.Options
|
||||
@ -231,7 +231,7 @@ instance Csv.ToNamedRecord LmsTableCsv where
|
||||
toNamedRecord = Csv.genericToNamedRecord ltcOptions
|
||||
|
||||
instance Csv.DefaultOrdered LmsTableCsv where
|
||||
headerOrder = Csv.genericHeaderOrder ltcOptions
|
||||
headerOrder = Csv.genericHeaderOrder ltcOptions
|
||||
|
||||
instance CsvColumnsExplained LmsTableCsv where
|
||||
csvColumnsExplanations = genericCsvColumnsExplanations ltcOptions $ Map.fromList
|
||||
@ -253,7 +253,7 @@ type LmsTableExpr = ( E.SqlExpr (Entity QualificationUser)
|
||||
`E.InnerJoin` E.SqlExpr (Entity User)
|
||||
) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity LmsUser))
|
||||
`E.LeftOuterJoin` E.SqlExpr (Maybe (Entity PrintJob))
|
||||
|
||||
|
||||
|
||||
queryQualUser :: LmsTableExpr -> E.SqlExpr (Entity QualificationUser)
|
||||
queryQualUser = $(sqlIJproj 2 1) . $(sqlLOJproj 3 1)
|
||||
@ -320,11 +320,11 @@ lmsTableQuery :: QualificationId -> LmsTableExpr -> E.SqlQuery ( E.SqlExpr (Enti
|
||||
)
|
||||
lmsTableQuery qid (qualUser `E.InnerJoin` user `E.LeftOuterJoin` lmsUser `E.LeftOuterJoin` printJob) = do
|
||||
-- E.distinctOn [E.don $ printJob E.?. PrintJobLmsUser] $ do -- types, but destroys the ability to sort interactively, since distinctOn requires sorting
|
||||
E.on $ lmsUser E.?. LmsUserId E.=?. printJob E.?. PrintJobLmsUser
|
||||
E.on $ lmsUser E.?. LmsUserIdent E.=?. printJob E.?. PrintJobLmsUser
|
||||
E.on $ user E.^. UserId E.=?. lmsUser E.?. LmsUserUser
|
||||
E.&&. E.val qid E.=?. lmsUser E.?. LmsUserQualification -- NOTE: condition was once erroneously placed in where-clause
|
||||
E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser
|
||||
E.where_ $ E.val qid E.==. qualUser E.^. QualificationUserQualification
|
||||
E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser
|
||||
E.where_ $ E.val qid E.==. qualUser E.^. QualificationUserQualification
|
||||
return (qualUser, user, lmsUser, printJob)
|
||||
|
||||
|
||||
@ -333,22 +333,22 @@ mkLmsTable :: forall h p cols act act'.
|
||||
, Ord act, PathPiece act, RenderMessage UniWorX act
|
||||
, AsCornice h p LmsTableData (DBCell (MForm Handler) (FormResult (First act', DBFormResult UserId Bool LmsTableData))) cols
|
||||
)
|
||||
=> Entity Qualification
|
||||
=> Entity Qualification
|
||||
-> Map act (AForm Handler act')
|
||||
-> (LmsTableExpr -> E.SqlExpr (E.Value Bool))
|
||||
-> cols
|
||||
-> PSValidator (MForm Handler) (FormResult (First act', DBFormResult UserId Bool LmsTableData))
|
||||
-> DB (FormResult (act', Set UserId), Widget)
|
||||
mkLmsTable (Entity qid quali) acts restrict cols psValidator = do
|
||||
now <- liftIO getCurrentTime
|
||||
now <- liftIO getCurrentTime
|
||||
-- currentRoute <- fromMaybe (error "mkLmsAllTable called from 404-handler") <$> liftHandler getCurrentRoute -- we know the route here
|
||||
let
|
||||
let
|
||||
currentRoute = LmsR (qualificationSchool quali) (qualificationShorthand quali)
|
||||
nowaday = utctDay now
|
||||
mbRenewal = addGregorianDurationClip <$> qualificationRefreshWithin quali <*> Just nowaday
|
||||
csvName = T.replace " " "-" $ CI.original (quali ^. _qualificationName)
|
||||
dbtIdent :: Text
|
||||
dbtIdent = "qualification"
|
||||
dbtIdent = "qualification"
|
||||
dbtSQLQuery q = lmsTableQuery qid q <* E.where_ (restrict q)
|
||||
dbtRowKey = queryUser >>> (E.^. UserId)
|
||||
dbtProj = dbtProjFilteredPostId
|
||||
@ -359,7 +359,7 @@ mkLmsTable (Entity qid quali) acts restrict cols psValidator = do
|
||||
, single ("blocked-due" , SortColumn $ queryQualUser >>> (E.^. QualificationUserBlockedDue))
|
||||
, single ("valid-until" , SortColumn $ queryQualUser >>> (E.^. QualificationUserValidUntil))
|
||||
, single ("last-refresh", SortColumn $ queryQualUser >>> (E.^. QualificationUserLastRefresh))
|
||||
, single ("first-held" , SortColumn $ queryQualUser >>> (E.^. QualificationUserFirstHeld))
|
||||
, single ("first-held" , SortColumn $ queryQualUser >>> (E.^. QualificationUserFirstHeld))
|
||||
, single ("lms-ident" , SortColumn $ queryLmsUser >>> (E.?. LmsUserIdent))
|
||||
, single ("lms-status" , SortColumn $ views (to queryLmsUser) (E.?. LmsUserStatus))
|
||||
, single ("lms-started" , SortColumn $ queryLmsUser >>> (E.?. LmsUserStarted))
|
||||
@ -383,11 +383,11 @@ mkLmsTable (Entity qid quali) acts restrict cols psValidator = do
|
||||
)
|
||||
-- , single ("lms-notified", FilterColumn . E.mkExactFilterLast $ views (to queryLmsUser) (E.isJust . (E.?. LmsUserNotified)))
|
||||
, single ("lms-notified", FilterColumn $ \row criterion ->
|
||||
let luser = queryLmsUser row
|
||||
let luser = queryLmsUser row
|
||||
pjob = queryPrintJob row
|
||||
in
|
||||
in
|
||||
case getLast criterion of
|
||||
Just True -> E.isJust (luser E.?. LmsUserNotified)
|
||||
Just True -> E.isJust (luser E.?. LmsUserNotified)
|
||||
E.&&. (E.isNothing (pjob E.?. PrintJobId) E.||. E.isJust (pjob E.?. PrintJobAcknowledged))
|
||||
Just False -> E.isNothing (luser E.?. LmsUserNotified)
|
||||
E.||. (E.isJust (pjob E.?. PrintJobId) E.&&. E.isNothing (pjob E.?. PrintJobAcknowledged))
|
||||
@ -403,7 +403,7 @@ mkLmsTable (Entity qid quali) acts restrict cols psValidator = do
|
||||
, if isNothing mbRenewal then mempty
|
||||
else prismAForm (singletonFilter "renewal-due" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsRenewal)
|
||||
]
|
||||
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
|
||||
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
|
||||
dbtCsvEncode = Just DBTCsvEncode
|
||||
{ dbtCsvExportForm = pure ()
|
||||
, dbtCsvDoEncode = \() -> C.map (doEncode' . view _2)
|
||||
@ -465,7 +465,7 @@ mkLmsTable (Entity qid quali) acts restrict cols psValidator = do
|
||||
getLmsR, postLmsR :: SchoolId -> QualificationShorthand -> Handler Html
|
||||
getLmsR = postLmsR
|
||||
postLmsR sid qsh = do
|
||||
currentRoute <- fromMaybe (error "correctionsR called from 404-handler") <$> getCurrentRoute -- This should never be called from a 404 handler
|
||||
currentRoute <- fromMaybe (error "correctionsR called from 404-handler") <$> getCurrentRoute -- This should never be called from a 404 handler
|
||||
((lmsRes, lmsTable), Entity qid quali) <- runDB $ do
|
||||
qent <- getBy404 $ SchoolQualificationShort sid qsh
|
||||
let acts :: Map LmsTableAction (AForm Handler LmsTableActionData)
|
||||
@ -489,8 +489,8 @@ postLmsR sid qsh = do
|
||||
, sortable (Just "lms-datepin") (i18nLms MsgTableLmsDatePin) $ \(preview $ resultLmsUser . _entityVal . _lmsUserDatePin -> d) -> foldMap dateTimeCell d
|
||||
, sortable (Just "lms-received") (i18nLms MsgTableLmsReceived) $ \(preview $ resultLmsUser . _entityVal . _lmsUserReceived -> d) -> foldMap dateTimeCell $ join d
|
||||
--, sortable (Just "lms-notified") (i18nLms MsgTableLmsNotified) $ \(preview $ resultLmsUser . _entityVal . _lmsUserNotified -> d) -> foldMap dateTimeCell $ join d
|
||||
, sortable (Just "lms-notified") (i18nLms MsgTableLmsNotified) $ \row ->
|
||||
-- 4 Cases:
|
||||
, sortable (Just "lms-notified") (i18nLms MsgTableLmsNotified) $ \row ->
|
||||
-- 4 Cases:
|
||||
-- - No notification: LmsUserNotified == Nothing
|
||||
-- - Email sent : LmsUserNotified == Just _ && PrintJobId == Nothing
|
||||
-- - Letter printed : LmsUserNotified == Just _ && PrintJobId == Just _
|
||||
@ -498,15 +498,15 @@ postLmsR sid qsh = do
|
||||
let notifyDate = join $ row ^? resultLmsUser . _entityVal . _lmsUserNotified
|
||||
letterDate = join $ row ^? resultPrintJob . _entityVal . _printJobAcknowledged
|
||||
-- letterSent = isJust (row ^? resultPrintJob . _entityKey) && (isNothing letterDate || letterDate > notifyDate) -- bad idea, since a resending increase notifyDay but just reschedules a print job
|
||||
letterSent = isJust (row ^? resultPrintJob . _entityKey) -- note the difference to letterDate!
|
||||
letterSent = isJust (row ^? resultPrintJob . _entityKey) -- note the difference to letterDate!
|
||||
notNotified = isNothing notifyDate
|
||||
cIcon = iconFixedCell $ iconLetterOrEmail letterSent
|
||||
cDate = if letterSent
|
||||
then foldMap dateTimeCell letterDate
|
||||
else foldMap dateTimeCell notifyDate
|
||||
in if notNotified
|
||||
in if notNotified
|
||||
then mempty
|
||||
else cIcon <> spacerCell <> cDate
|
||||
else cIcon <> spacerCell <> cDate
|
||||
, sortable (Just "lms-ended") (i18nLms MsgTableLmsEnded) $ \(preview $ resultLmsUser . _entityVal . _lmsUserEnded -> d) -> foldMap dateTimeCell $ join d
|
||||
]
|
||||
where
|
||||
|
||||
@ -277,7 +277,7 @@ postLmsResultDirectR sid qsh = do
|
||||
$logWarnS "LMS" $ "Result upload failed parsing: " <> tshow e
|
||||
return (badRequest400, "Exception: " <> tshow e)
|
||||
Right nr -> do
|
||||
let msg = "Success. LMS Result upload file " <> fileName file <> " containing " <> tshow nr <> " rows for header " <> fhead
|
||||
let msg = "Success. LMS Result upload file " <> fileName file <> " containing " <> tshow nr <> " rows for file " <> fhead
|
||||
$logInfoS "LMS" msg
|
||||
when (nr > 0) $ queueDBJob $ JobLmsResults qid
|
||||
return (ok200, msg)
|
||||
|
||||
@ -273,7 +273,7 @@ postLmsUserlistDirectR sid qsh = do
|
||||
$logWarnS "LMS" $ "Userlist upload failed parsing: " <> tshow e
|
||||
return (badRequest400, "Exception: " <> tshow e)
|
||||
Right nr -> do
|
||||
let msg = "Success. LMS Userlist upload file " <> fileName file <> " containing " <> tshow nr <> " rows for header " <> fhead
|
||||
let msg = "Success. LMS Userlist upload file " <> fileName file <> " containing " <> tshow nr <> " rows for file " <> fhead
|
||||
$logInfoS "LMS" msg
|
||||
when (nr > 0) $ queueDBJob $ JobLmsUserlist qid
|
||||
return (ok200, msg)
|
||||
|
||||
@ -3,12 +3,15 @@
|
||||
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module Handler.PrintCenter
|
||||
( getPrintCenterR, postPrintCenterR
|
||||
, getPrintAcknowR, postPrintAcknowR
|
||||
( getPrintDownloadR
|
||||
, getPrintCenterR, postPrintCenterR
|
||||
, getPrintSendR , postPrintSendR
|
||||
, getPrintDownloadR
|
||||
, getPrintAckR , postPrintAckR
|
||||
, postPrintAckDirectR
|
||||
, postPrintAckFreeR
|
||||
) where
|
||||
|
||||
import Import
|
||||
@ -35,6 +38,8 @@ import Utils.Print
|
||||
-- import qualified Data.Set as Set
|
||||
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Csv
|
||||
import qualified Data.Csv as Csv
|
||||
|
||||
-- avoids repetition of local definitions
|
||||
single :: (k,a) -> Map k a
|
||||
@ -203,7 +208,7 @@ mkPJTable = do
|
||||
, sortable (Just "pj-sender") (i18nCell MsgPrintSender) $ \(preview resultSender -> u) -> maybeCell u $ cellHasUserLink AdminUserR
|
||||
, sortable (Just "pj-course") (i18nCell MsgPrintCourse) $ \(preview $ resultCourse . _entityVal -> c) -> maybeCell c courseCell
|
||||
, sortable (Just "pj-qualification")(i18nCell MsgPrintQualification) $ \(preview $ resultQualification . _entityVal -> q) -> maybeCell q qualificationCell
|
||||
, sortable (Just "pj-lmsid") (i18nCell MsgPrintLmsUser) $ \( view $ resultPrintJob . _entityVal . _printJobLmsUser -> q) -> ifIconCell (isJust q) IconMenuLms
|
||||
, sortable (Just "pj-lmsid") (i18nCell MsgPrintLmsUser) $ \( view $ resultPrintJob . _entityVal . _printJobLmsUser -> l) -> foldMap textCell (getLmsIdent <$> l)
|
||||
]
|
||||
dbtSorting = mconcat
|
||||
[ single ("pj-name" , SortColumn $ queryPrintJob >>> (E.^. PrintJobName))
|
||||
@ -214,7 +219,7 @@ mkPJTable = do
|
||||
, single ("pj-sender" , sortUserNameBareM querySender )
|
||||
, single ("pj-course" , SortColumn $ queryCourse >>> (E.?. CourseName))
|
||||
, single ("pj-qualification", SortColumn $ queryQualification >>> (E.?. QualificationName))
|
||||
, single ("pj-lmsid" , SortColumn $ queryPrintJob >>> (E.isJust . (E.^. PrintJobLmsUser)))
|
||||
, single ("pj-lmsid" , SortColumn $ queryPrintJob >>> (E.^. PrintJobLmsUser))
|
||||
]
|
||||
dbtFilter = mconcat
|
||||
[ single ("pj-name" , FilterColumn . E.mkContainsFilter $ views (to queryPrintJob) (E.^. PrintJobName))
|
||||
@ -357,12 +362,12 @@ getPrintDownloadR cupj = do
|
||||
-}
|
||||
|
||||
|
||||
getPrintAcknowR, postPrintAcknowR :: Day -> Int -> Int -> Handler Html
|
||||
getPrintAcknowR = postPrintAcknowR
|
||||
postPrintAcknowR ackDay numAck chksm = do
|
||||
getPrintAckR, postPrintAckR :: Day -> Int -> Int -> Handler Html
|
||||
getPrintAckR = postPrintAckR
|
||||
postPrintAckR ackDay numAck chksm = do
|
||||
((ackRes, ackWgt), ackEnctype) <- runFormPost (identifyForm FIDPrintAcknowledge buttonForm :: Form ButtonConfirm)
|
||||
let ackForm = wrapForm ackWgt def
|
||||
{ formAction = Just $ SomeRoute $ PrintAcknowR ackDay numAck chksm
|
||||
{ formAction = Just $ SomeRoute $ PrintAckR ackDay numAck chksm
|
||||
, formEncoding = ackEnctype
|
||||
, formSubmit = FormNoSubmit
|
||||
}
|
||||
@ -399,3 +404,50 @@ postPrintAcknowR ackDay numAck chksm = do
|
||||
(MsgPrintJobAcknowledgeQuestion numAck ackDayText)
|
||||
ackForm
|
||||
|
||||
-- no header csv, containing a single column of lms identifiers (logins)
|
||||
instance Csv.FromRecord LmsIdent -- default suffices
|
||||
|
||||
postPrintAckDirectR :: Handler Html
|
||||
postPrintAckDirectR = do
|
||||
(_params, files) <- runRequestBody
|
||||
(status, msg) <- case files of
|
||||
[(fhead,file)] -> do
|
||||
runDB $ do
|
||||
enr <- try $ runConduit $ fileSource file
|
||||
.| decodeCsvPositional Csv.NoHeader
|
||||
.| sinkList
|
||||
case enr of
|
||||
Left (e :: SomeException) -> do -- catch all to avoid ok220 in case of any error
|
||||
$logWarnS "APC" $ "Result upload failed parsing: " <> tshow e
|
||||
return (badRequest400, "Exception: " <> tshow e)
|
||||
Right lids -> do
|
||||
now <- liftIO getCurrentTime
|
||||
nr <- updateWhereCount
|
||||
[PrintJobAcknowledged ==. Nothing, PrintJobLmsUser <-. (Just <$> lids)]
|
||||
[PrintJobAcknowledged =. Just now]
|
||||
let lenLids = length lids
|
||||
if | lenLids <= 0 -> do
|
||||
let msg = "Error: No print job was acknowledged as printed, but " <> tshow lenLids <> " were requested to be, for file " <> fhead
|
||||
$logErrorS "APC" msg
|
||||
return (badRequest400, msg)
|
||||
| lenLids == fromIntegral nr -> do
|
||||
let msg = "Success: " <> tshow nr <> " print jobs were acknowledged as printed, for file " <> fhead
|
||||
$logInfoS "APC" msg
|
||||
return (ok200, msg)
|
||||
| otherwise -> do
|
||||
let msg = "Warning: Only " <> tshow nr <> " print jobs out of " <> tshow lenLids <> " were acknowledged as printed, for file " <> fhead
|
||||
$logWarnS "APC" msg
|
||||
return (ok200, msg)
|
||||
[] -> do
|
||||
let msg = "Warning: No file received. A file of lms identifiers must be supplied for print job acknowledging."
|
||||
$logWarnS "APC" msg
|
||||
return (badRequest400, msg)
|
||||
_other -> do
|
||||
let msg = "Error: Only a single file may be uploaded for print job acknowlegement; all ignored."
|
||||
$logErrorS "APC" msg
|
||||
return (badRequest400, msg)
|
||||
sendResponseStatus status msg -- must be outside of runDB; otherweise transaction is rolled back
|
||||
|
||||
-- synonym, used during development to test with and without access control simultaneously
|
||||
postPrintAckFreeR :: Handler Html
|
||||
postPrintAckFreeR = postPrintAckDirectR
|
||||
@ -126,7 +126,7 @@ dispatchNotificationQualificationRenewal nQualification jRecipient = do
|
||||
notifyOk <- pdfRenewal pdfMeta >>= \case
|
||||
Right pdf | userPrefersLetter recipient -> -- userPrefersLetter is false if both userEmail and userPostAddress are null
|
||||
let printSender = Nothing
|
||||
in runDB (sendLetter printJobName pdf (Just jRecipient, printSender) Nothing (Just nQualification) (Just luid)) >>= \case
|
||||
in runDB (sendLetter printJobName pdf (Just jRecipient, printSender) Nothing (Just nQualification) (Just lmsUserIdent)) >>= \case
|
||||
Left err -> do
|
||||
let msg = "Notify " <> tshow encRecipient <> ": PDF printing to send letter failed with error " <> cropText err
|
||||
$logErrorS "LMS" msg
|
||||
|
||||
@ -268,7 +268,7 @@ pdfRenewal' meta = do
|
||||
-- PrintJobs --
|
||||
---------------
|
||||
|
||||
sendLetter :: Text -> LBS.ByteString -> (Maybe UserId, Maybe UserId) -> Maybe CourseId -> Maybe QualificationId -> Maybe LmsUserId -> DB (Either Text (Text, FilePath))
|
||||
sendLetter :: Text -> LBS.ByteString -> (Maybe UserId, Maybe UserId) -> Maybe CourseId -> Maybe QualificationId -> Maybe LmsIdent -> DB (Either Text (Text, FilePath))
|
||||
sendLetter printJobName pdf (printJobRecipient, printJobSender) printJobCourse printJobQualification printJobLmsUser = do
|
||||
recipient <- join <$> mapM get printJobRecipient
|
||||
sender <- join <$> mapM get printJobSender
|
||||
@ -278,17 +278,17 @@ sendLetter printJobName pdf (printJobRecipient, printJobSender) printJobCourse p
|
||||
nameSender = abbrvName <$> sender
|
||||
nameCourse = CI.original . courseShorthand <$> course
|
||||
nameQuali = CI.original . qualificationShorthand <$> quali
|
||||
let printJobAcknowledged = Nothing
|
||||
jobFullName = T.replace " " "-" (T.intercalate "_" . catMaybes $ [Just printJobName, nameQuali, nameCourse, nameSender, nameRecipient])
|
||||
let jobFullName = T.replace " " "-" (T.intercalate "_" . catMaybes $ [Just printJobName, nameQuali, nameCourse, nameSender, nameRecipient])
|
||||
printJobFilename = T.unpack $ jobFullName <> ".pdf"
|
||||
-- printJobFile <- sinkFileDB True $ yield $ LBS.toStrict pdf -- for PrintJobFile :: FileContentReference use this code
|
||||
printJobFile = LBS.toStrict pdf
|
||||
printJobAcknowledged = Nothing
|
||||
lprPDF jobFullName pdf >>= \case
|
||||
Left err -> do
|
||||
return $ Left err
|
||||
Right ok -> do
|
||||
printJobCreated <- liftIO getCurrentTime
|
||||
updateWhere [PrintJobLmsUser ==. printJobLmsUser] [PrintJobLmsUser =. Nothing] -- only one printJob per LmsUser is allowed, since otherwise the qualification table contains double rows
|
||||
-- updateWhere [PrintJobLmsUser ==. printJobLmsUser] [PrintJobLmsUser =. Nothing] -- only one printJob per LmsUser is allowed, since otherwise the qualification table contains double rows
|
||||
insert_ PrintJob {..}
|
||||
return $ Right (ok, printJobFilename)
|
||||
|
||||
|
||||
@ -528,22 +528,22 @@ fillDb = do
|
||||
void . insert' $ LmsUserlist qid_f (LmsIdent "hijklmn") False now
|
||||
void . insert' $ LmsUserlist qid_f (LmsIdent "abcdefg") True now
|
||||
void . insert' $ LmsUserlist qid_f (LmsIdent "ijk" ) False now
|
||||
lujost <- insert' $ LmsUser qid_f jost (LmsIdent "ijk" ) "123" False now Nothing now Nothing (Just $ n_day' (-7)) (Just $ n_day' (-5))
|
||||
luvaupel <- insert' $ LmsUser qid_f svaupel (LmsIdent "abcdefg") "abc" False now (Just $ LmsSuccess $ n_day 1) now (Just now) (Just $ n_day' 0) Nothing
|
||||
void . insert' $ LmsUser qid_f gkleen (LmsIdent "hijklmn") "@#!" True now (Just $ LmsBlocked $ utctDay now) now (Just now) (Just $ n_day' (-1)) Nothing
|
||||
lutina <- insert' $ LmsUser qid_f tinaTester (LmsIdent "qwvu") "45678" True now (Just $ LmsSuccess $ n_day (-2)) now (Just $ n_day' (-1)) (Just $ n_day' (-1)) Nothing
|
||||
void . insert' $ LmsUser qid_f maxMuster (LmsIdent "xyz") "a1b2c3" False now (Just $ LmsBlocked $ n_day (-1)) now (Just $ n_day' (-2)) Nothing Nothing
|
||||
void . insert' $ LmsUser qid_f fhamann (LmsIdent "123") "456" False now Nothing now Nothing Nothing Nothing
|
||||
void . insert' $ LmsUser qid_f jost (LmsIdent "ijk" ) "123" False now Nothing now Nothing (Just $ n_day' (-7)) (Just $ n_day' (-5))
|
||||
void . insert' $ LmsUser qid_f svaupel (LmsIdent "abcdefg") "abc" False now (Just $ LmsSuccess $ n_day 1) now (Just now) (Just $ n_day' 0) Nothing
|
||||
void . insert' $ LmsUser qid_f gkleen (LmsIdent "hijklmn") "@#!" True now (Just $ LmsBlocked $ utctDay now) now (Just now) (Just $ n_day' (-1)) Nothing
|
||||
void . insert' $ LmsUser qid_f tinaTester (LmsIdent "qwvu") "45678" True now (Just $ LmsSuccess $ n_day (-2)) now (Just $ n_day' (-1)) (Just $ n_day' (-1)) Nothing
|
||||
void . insert' $ LmsUser qid_f maxMuster (LmsIdent "xyz") "a1b2c3" False now (Just $ LmsBlocked $ n_day (-1)) now (Just $ n_day' (-2)) Nothing Nothing
|
||||
void . insert' $ LmsUser qid_f fhamann (LmsIdent "123") "456" False now Nothing now Nothing Nothing Nothing
|
||||
|
||||
void . insert $ PrintJob "TestJob1" "job1" "No Text herein." (n_day' (-1)) Nothing Nothing (Just svaupel) Nothing (Just qid_f) Nothing
|
||||
void . insert $ PrintJob "TestJob2" "job2" "No Text herein." (n_day' (-3)) (Just $ n_day' (-1)) (Just jost) (Just svaupel) Nothing (Just qid_f) (Just lujost)
|
||||
void . insert $ PrintJob "TestJob2" "job2" "No Text herein." (n_day' (-3)) (Just $ n_day' (-1)) (Just jost) (Just svaupel) Nothing (Just qid_f) (Just $ LmsIdent "ijk")
|
||||
void . insert $ PrintJob "TestJob3" "job3" "No Text herein." (n_day' (-2)) Nothing Nothing Nothing Nothing Nothing Nothing
|
||||
void . insert $ PrintJob "TestJob4" "job4" "No Text herein." (n_day' (-2)) Nothing (Just jost) Nothing Nothing Nothing Nothing
|
||||
void . insert $ PrintJob "TestJob5" "job5" "No Text herein." (n_day' (-4)) Nothing (Just jost) (Just svaupel) Nothing (Just qid_r) (Just lutina)
|
||||
void . insert $ PrintJob "TestJob4" "job4" "No Text herein." (n_day' (-2)) Nothing (Just jost) Nothing Nothing Nothing (Just $ LmsIdent "qwvu")
|
||||
void . insert $ PrintJob "TestJob5" "job5" "No Text herein." (n_day' (-4)) Nothing (Just jost) (Just svaupel) Nothing (Just qid_r) (Just $ LmsIdent "qwvu")
|
||||
void . insert $ PrintJob "TestJob6" "job6" "No Text herein." (n_day' (-4)) Nothing (Just svaupel) Nothing Nothing (Just qid_r) Nothing
|
||||
void . insert $ PrintJob "TestJob7" "job7" "No Text herein." (n_day' (-4)) (Just $ n_day' (-8)) (Just svaupel) Nothing Nothing Nothing (Just luvaupel)
|
||||
void . insert $ PrintJob "TestJob8" "job8" "No Text herein." (n_day' (-2)) (Just $ n_day' (-6)) (Just svaupel) Nothing Nothing Nothing (Just luvaupel)
|
||||
void . insert $ PrintJob "TestJob8" "job8" "No Text herein." (n_day' (-1)) Nothing (Just svaupel) Nothing Nothing Nothing (Just luvaupel)
|
||||
void . insert $ PrintJob "TestJob7" "job7" "No Text herein." (n_day' (-4)) (Just $ n_day' (-8)) (Just svaupel) Nothing Nothing Nothing (Just $ LmsIdent "abcdefg")
|
||||
void . insert $ PrintJob "TestJob8" "job8" "No Text herein." (n_day' (-2)) (Just $ n_day' (-6)) (Just svaupel) Nothing Nothing Nothing (Just $ LmsIdent "abcdefg")
|
||||
void . insert $ PrintJob "TestJob8" "job8" "No Text herein." (n_day' (-1)) Nothing (Just svaupel) Nothing Nothing Nothing (Just $ LmsIdent "abcdefg")
|
||||
|
||||
|
||||
let
|
||||
|
||||
Loading…
Reference in New Issue
Block a user