diff --git a/messages/uniworx/categories/print/de-de-formal.msg b/messages/uniworx/categories/print/de-de-formal.msg index c5a134c12..88b38730a 100644 --- a/messages/uniworx/categories/print/de-de-formal.msg +++ b/messages/uniworx/categories/print/de-de-formal.msg @@ -21,4 +21,5 @@ PrintQualification: Qualifikation PrintPDF !ident-ok: PDF PrintManualRenewal: Vorfeldführerschein Renewal-Brief testweise versenden PrintLmsUser: E‑Learning Id -PrintJobs: Druckaufräge \ No newline at end of file +PrintJobs: Druckaufräge +PrintLetterType: Brieftypkürzel \ No newline at end of file diff --git a/messages/uniworx/categories/print/en-eu.msg b/messages/uniworx/categories/print/en-eu.msg index 770a23725..5cf800eb3 100644 --- a/messages/uniworx/categories/print/en-eu.msg +++ b/messages/uniworx/categories/print/en-eu.msg @@ -21,4 +21,5 @@ PrintQualification: Qualification PrintPDF: PDF PrintManualRenewal: Manual sending of an apron driver's licence renewal letter PrintLmsUser: E‑learning id -PrintJobs: Print jobs \ No newline at end of file +PrintJobs: Print jobs +PrintLetterType: Letter type shorthand \ No newline at end of file diff --git a/messages/uniworx/categories/qualification/de-de-formal.msg b/messages/uniworx/categories/qualification/de-de-formal.msg index eae8b0e69..71549a505 100644 --- a/messages/uniworx/categories/qualification/de-de-formal.msg +++ b/messages/uniworx/categories/qualification/de-de-formal.msg @@ -19,6 +19,7 @@ TableQualificationSapExport: SAP TableQualificationSapExportTooltip: Wird die Qualifikation an das SAP übermittelt? Betrifft nur Benutzer mit Fraport Personalnummer. LmsQualificationValidUntil: Gültig bis TableQualificationLastRefresh: Zuletzt erneuert +TableQualificationLastNotified: Letzte Benachrichtigung TableQualificationFirstHeld: Erstmalig TableQualificationBlockedDue: Entzogen TableQualificationBlockedTooltip: Wann wurde die Qualifikation vorübergehend außer Kraft gesetzt und warum wurde dies veranlasst? diff --git a/messages/uniworx/categories/qualification/en-eu.msg b/messages/uniworx/categories/qualification/en-eu.msg index 77a2dfbb5..674a34804 100644 --- a/messages/uniworx/categories/qualification/en-eu.msg +++ b/messages/uniworx/categories/qualification/en-eu.msg @@ -19,6 +19,7 @@ TableQualificationSapExport: Sent to SAP TableQualificationSapExportTooltip: Is this qualification transmitted to SAP? Only applies to qualification holder having a Fraport AG personnel number. LmsQualificationValidUntil: Valid until TableQualificationLastRefresh: Last renewed +TableQualificationLastNotified: Last notified TableQualificationFirstHeld: First held TableQualificationBlockedDue: Revoked TableQualificationBlockedTooltip: Why and when was this qualification temporarily suspended? diff --git a/models/lms.model b/models/lms.model index f96aca375..4f841f984 100644 --- a/models/lms.model +++ b/models/lms.model @@ -62,6 +62,7 @@ QualificationUser firstHeld Day -- first time the qualification was earned, should never change blockedDue QualificationBlocked Maybe -- isJust means that the qualification is currently revoked scheduleRenewal Bool default=true -- if false, no automatic renewal is scheduled and the qualification expires + lastNotified UTCTime default=now() -- last notficiation about being invalid -- temporärer Entzug vorsehen -- SAP Schnittstelle muss dann angepasst werden -- Begründungsfeld vorsehen UniqueQualificationUser qualification user diff --git a/src/Handler/Admin/Test.hs b/src/Handler/Admin/Test.hs index 7d80b6fc8..ff3904e6e 100644 --- a/src/Handler/Admin/Test.hs +++ b/src/Handler/Admin/Test.hs @@ -320,7 +320,7 @@ getAdminTestPdfR = do , qualDuration = qual ^. _qualificationValidDuration } apcIdent <- letterApcIdent letter encRecipient now - renderLetter usr letter apcIdent >>= \case + renderLetterPDF usr letter apcIdent >>= \case Left err -> sendResponseStatus internalServerError500 $ "PDF generation failed: \n" <> err Right pdf -> do liftIO $ LBS.writeFile "/tmp/generated.pdf" pdf diff --git a/src/Handler/LMS/Fake.hs b/src/Handler/LMS/Fake.hs index c3693e544..e0550e574 100644 --- a/src/Handler/LMS/Fake.hs +++ b/src/Handler/LMS/Fake.hs @@ -131,6 +131,7 @@ fakeQualificationUsers (Entity qid Qualification{qualificationRefreshWithin}) (u qualificationUserLastRefresh = qualificationUserFirstHeld qualificationUserBlockedDue = Nothing qualificationUserScheduleRenewal = True + qualificationUserLastNotified = now _ <- upsert QualificationUser{..} [ QualificationUserValidUntil =. qualificationUserValidUntil , QualificationUserLastRefresh =. qualificationUserLastRefresh diff --git a/src/Handler/PrintCenter.hs b/src/Handler/PrintCenter.hs index c80c669a9..41fa484d3 100644 --- a/src/Handler/PrintCenter.hs +++ b/src/Handler/PrintCenter.hs @@ -46,20 +46,20 @@ data LRQF = LRQF , lrqfQuali :: Entity Qualification , lrqfIdent :: LmsIdent , lrqfPin :: Text - , lrqfExpiry :: Day + , lrqfExpiry :: Maybe Day } deriving (Eq, Generic) makeRenewalForm :: Maybe LRQF -> Form LRQF makeRenewalForm tmpl = identifyForm FIDLmsLetter . validateForm validateLetterRenewQualificationF $ \html -> do -- now_day <- utctDay <$> liftIO getCurrentTime flip (renderAForm FormStandard) html $ LRQF - <$> areq textField (fslI MsgLmsUser) (lrqfLetter <$> tmpl) + <$> areq textField (fslI MsgPrintLetterType) (lrqfLetter <$> tmpl) <*> areq (userField False Nothing) (fslI MsgLmsUser) (lrqfUser <$> tmpl) <*> aopt (userField False Nothing) (fslI MsgTableSupervisor) (lrqfSuper <$> tmpl) <*> areq qualificationFieldEnt (fslI MsgQualificationName) (lrqfQuali <$> tmpl) <*> areq lmsField (fslI MsgTableLmsIdent) (lrqfIdent <$> tmpl) <*> areq textField (fslI MsgTableLmsPin) (lrqfPin <$> tmpl) - <*> areq dayField (fslI MsgLmsQualificationValidUntil) (lrqfExpiry <$> tmpl) + <*> aopt dayField (fslI MsgLmsQualificationValidUntil) (lrqfExpiry <$> tmpl) where lmsField = convertField LmsIdent getLmsIdent textField @@ -73,13 +73,14 @@ lrqf2letter LRQF{..} | lrqfLetter == "r" = do usr <- getUser lrqfUser rcvr <- mapM getUser lrqfSuper + now <- liftIO getCurrentTime let letter = LetterRenewQualificationF { lmsLogin = lrqfIdent , lmsPin = lrqfPin , qualHolderID = usr ^. _entityKey , qualHolderDN = usr ^. _userDisplayName , qualHolderSN = usr ^. _userSurname - , qualExpiry = lrqfExpiry + , qualExpiry = fromMaybe (utctDay now) lrqfExpiry , qualId = lrqfQuali ^. _entityKey , qualName = lrqfQuali ^. _qualificationName . _CI , qualShort = lrqfQuali ^. _qualificationShorthand . _CI @@ -87,10 +88,11 @@ lrqf2letter LRQF{..} , qualDuration = lrqfQuali ^. _qualificationValidDuration } return (fromMaybe usr rcvr, SomeLetter letter) - | lrqfLetter == "e" = do + | lrqfLetter == "e" || lrqfLetter == "E" = do rcvr <- mapM getUser lrqfSuper usr <- getUser lrqfUser usrUuid <- encrypt $ entityKey usr + urender <- liftHandler getUrlRender let letter = LetterExpireQualificationF { leqfHolderUUID = usrUuid , leqfHolderID = usr ^. _entityKey @@ -101,6 +103,7 @@ lrqf2letter LRQF{..} , leqfName = lrqfQuali ^. _qualificationName . _CI , leqfShort = lrqfQuali ^. _qualificationShorthand . _CI , leqfSchool = lrqfQuali ^. _qualificationSchool + , leqfUrl = pure . urender $ ForProfileDataR usrUuid } return (fromMaybe usr rcvr, SomeLetter letter) | otherwise = error "Unknown Letter Type encountered. Use 'e' or 'r' only." @@ -305,23 +308,31 @@ postPrintSendR = do , lrqfQuali = qual , lrqfIdent = LmsIdent "stuvwxyz" , lrqfPin = "76543210" - , lrqfExpiry = succ nowaday + , lrqfExpiry = Just $ succ nowaday } def_lrqf = mkLetter <$> mbQual ((sendResult, sendWidget), sendEnctype) <- runFormPost $ makeRenewalForm def_lrqf - let procFormSend lrqf = do - ok <- (runDB (lrqf2letter lrqf) >>= printLetter (Just uid)) >>= \case - 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 - when ok $ redirect PrintCenterR + let procFormSend lrqf = case lrqfLetter lrqf of + "E" -> (runDB (lrqf2letter lrqf) >>= printHtml (Just uid)) >>= \case + Right html -> sendResponse $ toTypedContent html + Left err -> do + let msg = "PDF printing failed with error: " <> err + $logErrorS "LPR" msg + addMessage Error $ toHtml msg + pure () + _ -> do + ok <- (runDB (lrqf2letter lrqf) >>= printLetter (Just uid)) >>= \case + 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 + when ok $ redirect PrintCenterR formResult sendResult procFormSend -- actionUrl <- fromMaybe AdminAvsR <$> getCurrentRoute siteLayoutMsg MsgPrintManualRenewal $ do diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index 2a5e2c0b8..52e3f43ee 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -339,7 +339,8 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do , single $ sortUserEmail queryUser , single $ sortUserMatriclenr queryUser , single ("valid-until" , SortColumn $ queryQualUser >>> (E.^. QualificationUserValidUntil)) - , single ("last-refresh" , SortColumn $ queryQualUser >>> (E.^. QualificationUserLastRefresh)) + , single ("last-refresh" , SortColumn $ queryQualUser >>> (E.^. QualificationUserLastRefresh)) + , single ("last-notified" , SortColumn $ queryQualUser >>> (E.^. QualificationUserLastNotified)) , single ("blocked-due" , SortColumnNeverNull $ queryQualUser >>> (E.^. QualificationUserBlockedDue)) -- , single ("lms-started" , SortColumn $ queryLmsUser >>> (E.?. LmsUserStarted)) -- , single ("lms-status" , SortColumn $ views (to queryLmsUser) (E.?. LmsUserStatus)) @@ -520,7 +521,8 @@ postQualificationR sid qsh = do -- $ \(preview $ resultLmsUser . _entityVal . _lmsUserStarted -> d) -> foldMap dateTimeCell d -- , sortable (Just "lms-status") (i18nCell MsgTableLmsStatus) $ \(preview $ resultLmsUser . _entityVal . _lmsUserStatus -> status) -> foldMap lmsStatusCell $ join status , sortable (Just "lms-status-plus")(i18nCell MsgTableLmsStatus & cellTooltipWgt Nothing (lmsStatusInfoCell isAdmin auditMonths)) - $ \(preview $ resultLmsUser . _entityVal -> lu) -> foldMap (lmsStatusPlusCell linkLmsUser) lu + $ \(preview $ resultLmsUser . _entityVal -> lu) -> foldMap (lmsStatusPlusCell linkLmsUser) lu + , sortable (Just "last-notified") (i18nCell MsgTableQualificationLastNotified) $ \( view $ resultQualUser . _entityVal . _qualificationUserLastNotified -> d) -> dateTimeCell d ] psValidator = def & defaultSorting [SortDescBy "last-refresh"] tbl <- mkQualificationTable isAdmin qent acts colChoices psValidator diff --git a/src/Handler/Utils/Qualification.hs b/src/Handler/Utils/Qualification.hs index c259e9867..6964073c5 100644 --- a/src/Handler/Utils/Qualification.hs +++ b/src/Handler/Utils/Qualification.hs @@ -14,7 +14,7 @@ import Database.Persist.Sql (updateWhereCount) import qualified Database.Esqueleto.Experimental as E -- might need TypeApplications Lang-Pragma import qualified Database.Esqueleto.Utils as E - +import Handler.Utils.DateTime (toMidnight) ------------------ -- SQL Snippets -- @@ -57,6 +57,7 @@ upsertQualificationUser qualificationUserQualification qualificationUserLastRef { qualificationUserFirstHeld = qualificationUserLastRefresh , qualificationUserBlockedDue = Nothing , qualificationUserScheduleRenewal = fromMaybe True mbScheduleRenewal + , qualificationUserLastNotified = toMidnight qualificationUserLastRefresh , .. } ( diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs index f583e65b1..087a543a7 100644 --- a/src/Handler/Utils/Users.hs +++ b/src/Handler/Utils/Users.hs @@ -827,6 +827,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do E.<&> (qualificationUser E.^. QualificationUserFirstHeld) E.<&> (qualificationUser E.^. QualificationUserBlockedDue) E.<&> (qualificationUser E.^. QualificationUserScheduleRenewal) + E.<&> (qualificationUser E.^. QualificationUserLastNotified) ) (\current excluded -> [ QualificationUserValidUntil E.=. combineWith current excluded E.greatest QualificationUserValidUntil @@ -834,6 +835,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do , QualificationUserFirstHeld E.=. combineWith current excluded E.least QualificationUserFirstHeld , QualificationUserBlockedDue E.=. combineWith current excluded E.greatest QualificationUserBlockedDue -- Tested: PostgreSQL GREATEST/LEAST ignores NULL values , QualificationUserScheduleRenewal E.=. combineWith current excluded E.greatest QualificationUserScheduleRenewal + , QualificationUserLastNotified E.=. combineWith current excluded E.greatest QualificationUserLastNotified ] ) deleteWhere [ QualificationUserUser ==. oldUserId ] diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index 074a3b866..eb92356ac 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -145,7 +145,7 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act -- end users that expired by doing nothing expiredLearners <- E.select $ do (quser :& luser) <- E.from $ - E.table @QualificationUser + E.table @QualificationUser `E.innerJoin` E.table @LmsUser `E.on` (\(quser :& luser) -> luser E.^. LmsUserUser E.==. quser E.^. QualificationUserUser @@ -158,13 +158,23 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act E.set luser [LmsUserStatus E.=. E.justVal (LmsExpired nowaday)] E.where_ $ (luser E.^. LmsUserId) `E.in_` E.valList (E.unValue <$> expiredLearners) $logInfoS "LMS" $ "Expired lms users " <> tshow nrExpired <> " for qualification " <> qshort - -- TODO: notify expired used - -- - -- forM_ expiredLearners $ \uid -> - -- queueDBJob JobSendNotification - -- { jRecipient = uid - -- , jNotification = NotificationQualificationExpired { nQualification = qid, nExpiry = nowaday } - -- } + + notifyInvalidDrivers <- E.select $ do + quser <- E.from $ E.table @QualificationUser + E.where_ $ E.not_ (validQualification nowaday quser) + E.&&. (( E.isNothing (quser E.^. QualificationUserBlockedDue) + E.&&. (E.day (quser E.^. QualificationUserLastNotified) E.<. quser E.^. QualificationUserValidUntil) + ) E.||. ( + E.isJust (quser E.^. QualificationUserBlockedDue) + E.&&. (E.day (quser E.^. QualificationUserLastNotified) E.<. ((quser E.^. QualificationUserBlockedDue) E.->. "day" :: E.SqlExpr (E.Value Day))) + )) + pure (quser E.^. QualificationUserUser) + + forM_ notifyInvalidDrivers $ \(E.Value uid) -> + queueDBJob JobSendNotification + { jRecipient = uid + , jNotification = NotificationQualificationExpired { nQualification = qid } + } -- purge outdated LmsUsers case qualificationAuditDuration quali of @@ -306,10 +316,11 @@ dispatchJobLmsUserlist qid = JobHandlerAtomic act } update luid [LmsUserStatus =. newStatus] void $ qualificationUserBlocking qid [lmsUserUser luser] $ Just $ mkQualificationBlocked QualificationBlockFailedELearning lmsMsgDay - queueDBJob JobSendNotification - { jRecipient = lmsUserUser luser - , jNotification = NotificationQualificationExpired { nQualification = qid, nExpiry = lmsMsgDay } - } + -- DEACTIVATED FOR NOW; UPON REACTIVATION: DELAY Sending to check for unblocking a few hours later! + -- queueDBJob JobSendNotification + -- { jRecipient = lmsUserUser luser + -- , jNotification = NotificationQualificationExpired { nQualification = qid } + -- } delete lulid $logInfoS "LmsUserlist" [st|Processed LMS Userlist with ${tshow (length results)} entries|] diff --git a/src/Jobs/Handler/SendNotification/Qualification.hs b/src/Jobs/Handler/SendNotification/Qualification.hs index 852bee308..6c438ded8 100644 --- a/src/Jobs/Handler/SendNotification/Qualification.hs +++ b/src/Jobs/Handler/SendNotification/Qualification.hs @@ -42,25 +42,44 @@ dispatchNotificationQualificationExpiry nQualification dExpiry jRecipient = user addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/qualificationExpiry.hamlet") -dispatchNotificationQualificationExpired :: QualificationId -> Day -> UserId -> Handler () -dispatchNotificationQualificationExpired nQualification dExpired jRecipient = userMailT jRecipient $ do - (recipient@User{..}, Qualification{..}) <- liftHandler . runDB $ (,) - <$> getJust jRecipient - <*> getJust nQualification +dispatchNotificationQualificationExpired :: QualificationId -> UserId -> Handler () +dispatchNotificationQualificationExpired nQualification jRecipient = do + encRecipient :: CryptoUUIDUser <- encrypt jRecipient + dbRes <- runDB $ (,,) + <$> get jRecipient + <*> get nQualification + <*> getBy (UniqueQualificationUser nQualification jRecipient) - encRecipient :: CryptoUUIDUser <- liftHandler $ encrypt jRecipient - let entRecipient = Entity jRecipient recipient - qname = CI.original qualificationName - expiryDate <- formatTimeUser SelFormatDate dExpired $ Just entRecipient - - $logDebugS "LMS" $ "Notify " <> tshow encRecipient <> " about expired qualification " <> qname - - replaceMailHeader "Auto-Submitted" $ Just "auto-generated" - setSubjectI $ MsgMailSubjectQualificationExpired qname - - editNotifications <- mkEditNotifications jRecipient - - addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/qualificationExpired.hamlet") + case dbRes of + ( Just User{..}, Just Qualification{..}, Just (Entity quId QualificationUser{..})) -> do + urender <- getUrlRender + let expDay = maybe qualificationUserValidUntil (min qualificationUserValidUntil . qualificationBlockedDay) qualificationUserBlockedDue + qname = CI.original qualificationName + qshort = CI.original qualificationShorthand + letter = LetterExpireQualificationF + { leqfHolderUUID = encRecipient + , leqfHolderID = jRecipient + , leqfHolderDN = userDisplayName + , leqfHolderSN = userSurname + , leqfExpiry = Just expDay + , leqfId = nQualification + , leqfName = qname + , leqfShort = qshort + , leqfSchool = qualificationSchool + , leqfUrl = pure . urender $ ForProfileDataR encRecipient + } + if expDay > utctDay qualificationUserLastNotified + then do + notifyOk <- sendEmailOrLetter jRecipient letter + if notifyOk + then do + now <- liftIO getCurrentTime + runDB $ update quId [QualificationUserLastNotified =. now] + $logInfoS "LMS" $ "Notified " <> tshow encRecipient <> " about expired qualification " <> qname + else + $logErrorS "LMS" $ "Failed to notify " <> tshow encRecipient <> " about expired qualification " <> qname + else $logErrorS "LMS" $ "Suppressed repeated notification " <> tshow encRecipient <> " about expired qualification " <> qname + _ -> $logErrorS "LMS" $ "Failed to notify " <> tshow encRecipient <> " about expired qualification " <> tshow nQualification -- NOTE: Renewal expects that LmsUser already exists for recipient @@ -75,7 +94,7 @@ dispatchNotificationQualificationRenewal nQualification jRecipient = do case query of (Just User{userDisplayName, userSurname}, Just Qualification{..}, Just (Entity _ QualificationUser{..}), Just(Entity luid LmsUser{..})) -> do let qname = CI.original qualificationName - let letter = LetterRenewQualificationF + letter = LetterRenewQualificationF { lmsLogin = lmsUserIdent , lmsPin = lmsUserPin , qualHolderID = jRecipient diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index 410a2d960..85fbaded8 100644 --- a/src/Jobs/Types.hs +++ b/src/Jobs/Types.hs @@ -142,7 +142,7 @@ data Notification | NotificationSubmissionUserCreated { nUser :: UserId, nSubmission :: SubmissionId } | NotificationSubmissionUserDeleted { nUser :: UserId, nSheet :: SheetId, nSubmission :: SubmissionId } | NotificationQualificationExpiry { nQualification :: QualificationId, nExpiry :: Day } - | NotificationQualificationExpired { nQualification :: QualificationId, nExpiry :: Day } + | NotificationQualificationExpired { nQualification :: QualificationId } | NotificationQualificationRenewal { nQualification :: QualificationId } deriving (Eq, Ord, Show, Read, Generic) diff --git a/src/Model/Types/Avs.hs b/src/Model/Types/Avs.hs index a12980ed6..f1937c736 100644 --- a/src/Model/Types/Avs.hs +++ b/src/Model/Types/Avs.hs @@ -138,7 +138,7 @@ instance {-# OVERLAPS #-} Canonical (Maybe AvsInternalPersonalNo) where -- where x is an 8 digit AvsCardNo prefixed by zeros, see normalizeAvsCardNo -- and y is the 1 digit AvsVersionNo type AvsVersionNo = Text -- always 1 digit -newtype AvsCardNo = AvsCardNo { avsCardNo :: Text } -- always 8 digits +newtype AvsCardNo = AvsCardNo { avsCardNo :: Text } -- always 8 digits -- TODO: Create Smart Constructor deriving (Eq, Ord, Show, Generic) deriving newtype (NFData, PathPiece, Csv.ToField, Csv.FromField) -- No longer needed: @@ -162,7 +162,7 @@ data AvsFullCardNo = AvsFullCardNo { avsFullCardNo :: AvsCardNo, avsFullCardVers deriving (Eq, Ord, Generic, NFData) tshowAvsFullCardNo :: AvsFullCardNo -> Text -tshowAvsFullCardNo AvsFullCardNo{..} = avsCardNo avsFullCardNo <> Text.cons '.' avsFullCardVersion +tshowAvsFullCardNo AvsFullCardNo{..} = avsCardNo (canonical avsFullCardNo) <> Text.cons '.' avsFullCardVersion instance Show AvsFullCardNo where show = Text.unpack . tshowAvsFullCardNo @@ -170,7 +170,7 @@ instance Show AvsFullCardNo where readAvsFullCardNo :: Text -> Maybe AvsFullCardNo readAvsFullCardNo (Text.span Char.isDigit -> (c, Text.uncons -> Just ('.',v))) | not $ Text.null c, Just (Char.isDigit -> True, "") <- Text.uncons v - = Just $ AvsFullCardNo (AvsCardNo c) v + = Just $ AvsFullCardNo (AvsCardNo $ normalizeAvsCardNo c) v readAvsFullCardNo _ = Nothing instance PersistField AvsFullCardNo where diff --git a/src/Utils/Print.hs b/src/Utils/Print.hs index 72e689947..f1d3054de 100644 --- a/src/Utils/Print.hs +++ b/src/Utils/Print.hs @@ -5,10 +5,11 @@ {-# OPTIONS_GHC -fno-warn-unused-top-binds #-} module Utils.Print - ( renderLetter -- used for generating letter pdfs + ( renderLetterPDF -- used for generating letter pdfs , renderLetters , sendEmailOrLetter -- directly print or sends by email , printLetter -- always send a letter + , printHtml -- return letter as Html only , letterApcIdent -- create acknowledge string for APC , letterFileName -- default filename , encryptPDF @@ -145,8 +146,8 @@ pdfLaTeX lk doc = do makePDF writerOpts $ appMeta setIsDeFromLang doc -renderLetter :: (MDLetter l) => Entity User -> l -> Text -> Handler (Either Text LBS.ByteString) -renderLetter rcvrEnt@Entity{entityVal=rcvr} mdl apcIdent = do +renderLetterPDF :: (MDLetter l) => Entity User -> l -> Text -> Handler (Either Text LBS.ByteString) +renderLetterPDF rcvrEnt@Entity{entityVal=rcvr} mdl apcIdent = do now <- liftIO getCurrentTime formatter@DateTimeFormatter{ format } <- getDateTimeFormatterUser' rcvr let lang = selectDeEn $ rcvr & userLanguages -- select either German or English only, default de; see Utils.Lang @@ -165,6 +166,30 @@ renderLetter rcvrEnt@Entity{entityVal=rcvr} mdl apcIdent = do actRight e_md $ pdfLaTeX kind +renderLetterHtml :: (MDLetter l) => Entity User -> l -> Text -> Handler (Either Text Html) +renderLetterHtml rcvrEnt@Entity{entityVal=rcvr} mdl apcIdent = do + now <- liftIO getCurrentTime + formatter@DateTimeFormatter{ format } <- getDateTimeFormatterUser' rcvr + let lang = selectDeEn $ rcvr & userLanguages -- select either German or English only, default de; see Utils.Lang + kind = getLetterKind mdl + tmpl = getTemplate mdl + meta = addApcIdent apcIdent + <> letterMeta mdl formatter lang rcvrEnt + <> mkMeta + [ -- toMeta "lang" lang -- receiver language is decided in MDLetter instance, since some letters have fixed languages + toMeta "date" $ format SelFormatDate now + , toMeta "rcvr-name" $ rcvr & userDisplayName + , toMeta "address" $ fromMaybe [rcvr & userDisplayName] $ getPostalAddress rcvr + --, toMeta "rcvr-email" $ rcvr & userDisplayEmail -- note that some templates use "email" already otherwise + ] + e_md <- mdTemplating tmpl meta + actRight e_md $ \md -> pure . over _Left P.renderError . P.runPure $ do + html_tmpl <- compileTemplate $ templateHtml kind + -- html_tmpl <- ExceptT $ memcachedBy (Just . Right $ 6 * diffHour) ("LetterKind-Html: \n" <> tshow lk) (pure . over _Left P.renderError . P.runPure $ compileTemplate $ templateHtml lk) + let writerOpts = def { P.writerExtensions = P.pandocExtensions + , P.writerTemplate = Just html_tmpl } + P.writeHtml5 writerOpts $ appMeta setIsDeFromLang md + -- TODO: apcIdent does not make sense for multiple letters renderLetters :: (MDLetter l, Foldable f) => Entity User -> f l -> Text -> Handler (Either Text LBS.ByteString) renderLetters rcvrEnt@Entity{entityVal=rcvr} mdls apcIdent @@ -201,6 +226,15 @@ renderLetters rcvrEnt@Entity{entityVal=rcvr} mdls apcIdent -- PrintJobs -- --------------- +-- Only used in print-test-handler for PrintSendR +printHtml :: (MDLetter l) => Maybe UserId -> (Entity User, l) -> Handler (Either Text Html) +printHtml _senderId (rcvr, letter) = do + let rcvrId = rcvr ^. _entityKey + encRecipient :: CryptoUUIDUser <- encrypt rcvrId + now <- liftIO getCurrentTime + apcIdent <- letterApcIdent letter encRecipient now + renderLetterHtml rcvr letter apcIdent + -- Only used in print-test-handler for PrintSendR printLetter :: (MDLetter l) => Maybe UserId -> (Entity User, l) -> Handler (Either Text (Text, FilePath)) printLetter senderId (rcvr, letter) = do @@ -208,7 +242,7 @@ printLetter senderId (rcvr, letter) = do encRecipient :: CryptoUUIDUser <- encrypt rcvrId now <- liftIO getCurrentTime apcIdent <- letterApcIdent letter encRecipient now - pdf <- renderLetter rcvr letter apcIdent + pdf <- renderLetterPDF rcvr letter apcIdent let protoPji = getPJId letter pji = protoPji { pjiRecipient = Just rcvrId @@ -254,7 +288,7 @@ printLetter'' _ = do -} sendEmailOrLetter :: (MDLetter l, MDMail l) => UserId -> l -> Handler Bool -sendEmailOrLetter recipient letter = do +sendEmailOrLetter recipient letter = do (underling, receivers, undercopy) <- updateReceivers recipient -- TODO: check to avoid this almost circular dependency now <- liftIO getCurrentTime let pjid = getPJId letter @@ -262,58 +296,85 @@ sendEmailOrLetter recipient letter = do mailSubject = getMailSubject letter -- these are only needed if sent by email, but we're lazy anyway undername = underling ^. _userDisplayName -- nameHtml' underling undermail = CI.original $ underling ^. _userEmail + mr <- getMessageRender + let mailSupervisorSubject = SomeMessage $ "[SUPERVISOR] " <> mr mailSubject oks <- forM receivers $ \rcvrEnt@Entity{ entityKey = svr, entityVal = rcvrUsr } -> do encRecipient :: CryptoUUIDUser <- encrypt svr apcIdent <- letterApcIdent letter encRecipient now - let (preferPost, postal) = getPostalPreferenceAndAddress rcvrUsr - -- mailBody = getMailBody letter formatter - renderLetter rcvrEnt letter apcIdent >>= \case - _ | preferPost, isNothing postal -> do -- neither email nor postal is known + case getPostalPreferenceAndAddress rcvrUsr of + (True, Nothing) -> do -- neither email nor postal is known let msg = "Notification failed for " <> tshow encRecipient <> ", who has neither a known email nor postal address. Notification: " <> tshow pjid $logErrorS "LETTER" msg return False - Left err -> do -- pdf generation failed - let msg = "Notification failed for " <> tshow encRecipient <> ". PDF generation failed: "<> cropText err <> "For Notification: " <> tshow pjid - $logErrorS "LETTER" msg - return False - Right pdf | preferPost -> -- send printed letter - runDB (printLetter' pjid{pjiRecipient = Just svr, pjiApcAcknowledge = apcIdent} pdf) >>= \case - Left err -> do - let msg = "Notification failed for " <> tshow encRecipient <> ". PDF printing failed. The print job could not be sent: " <> cropText err + + (True , Just _postal) -> renderLetterPDF rcvrEnt letter apcIdent >>= \case -- send printed letter + Left err -> do -- pdf generation failed + let msg = "Notification failed for " <> tshow encRecipient <> ". PDF generation failed: "<> cropText err <> "For Notification: " <> tshow pjid $logErrorS "LETTER" msg - return False - Right (msg,_) - | null msg -> return True - | otherwise -> do - $logWarnS "LETTER" $ "PDF printing to send letter with lpr returned ExitSuccess and the following message: " <> msg - return True - Right pdf -> do -- send email - let pdfPass = case encryptPDFfor letter of - NoPassword -> Nothing - PasswordSupervisor -> rcvrUsr ^. _userPinPassword - PasswordUnderling -> underling ^. _userPinPassword - attachment <- case pdfPass of - Nothing -> return pdf - Just passwd -> encryptPDF passwd pdf >>= \case - Right encPdf -> return encPdf - Left err -> do - let msg = "Notification for " <> tshow encRecipient <> " has unencrypted attachment. Encrypting PDF failed: " <> cropText err - $logWarnS "LETTER" msg - return pdf - formatter <- getDateTimeFormatterUser' rcvrUsr -- not too expensive, only calls getTimeLocale - let isSupervised = recipient /= svr - supername = rcvrUsr ^. _userDisplayName -- nameHtml' rcvrUsr - mailBody = getMailBody letter formatter - userMailTdirect svr $ do - replaceMailHeader "Auto-Submitted" $ Just "auto-generated" - setSubjectI mailSubject - editNotifications <- mkEditNotifications svr - addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/genericMailLetter.hamlet") - addPart (File { fileTitle = fName - , fileModified = now - , fileContent = Just $ yield $ LBS.toStrict attachment - } :: PureFile) - return True + return False + Right pdf -> runDB (printLetter' pjid{pjiRecipient = Just svr, pjiApcAcknowledge = apcIdent} pdf) >>= \case + Left err -> do + let msg = "Notification failed for " <> tshow encRecipient <> ". PDF printing failed. The print job could not be sent: " <> cropText err + $logErrorS "LETTER" msg + return False + Right (msg,_) + | null msg -> return True + | otherwise -> do + $logWarnS "LETTER" $ "PDF printing to send letter with lpr returned ExitSuccess and the following message: " <> msg + return True + + (False, _) | attachPDFLetter letter -> renderLetterPDF rcvrEnt letter apcIdent >>= \case -- send Email, with pdf attached + Left err -> do -- pdf generation failed + let msg = "Notification failed for " <> tshow encRecipient <> ". PDF attachment generation failed: "<> cropText err <> "For Notification: " <> tshow pjid + $logErrorS "LETTER" msg + return False + Right pdf -> do -- pdf generated, send as email attachment now + let pdfPass = case encryptPDFfor letter of + NoPassword -> Nothing + PasswordSupervisor -> rcvrUsr ^. _userPinPassword + PasswordUnderling -> underling ^. _userPinPassword + attachment <- case pdfPass of + Nothing -> return pdf + Just passwd -> encryptPDF passwd pdf >>= \case + Right encPdf -> return encPdf + Left err -> do + let msg = "Notification for " <> tshow encRecipient <> " has unencrypted attachment. Encrypting PDF failed: " <> cropText err + $logWarnS "LETTER" msg + return pdf + formatter <- getDateTimeFormatterUser' rcvrUsr -- not too expensive, only calls getTimeLocale + let isSupervised = recipient /= svr + supername = rcvrUsr ^. _userDisplayName -- nameHtml' rcvrUsr + mailBody <- getMailBody letter formatter + userMailTdirect svr $ do + replaceMailHeader "Auto-Submitted" $ Just "auto-generated" + setSubjectI mailSubject + editNotifications <- mkEditNotifications svr + addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/genericMailLetter.hamlet") + addPart (File { fileTitle = fName + , fileModified = now + , fileContent = Just $ yield $ LBS.toStrict attachment + } :: PureFile) + return True + + (False, _) -> renderLetterHtml rcvrEnt letter apcIdent >>= \case -- send Email, render letter directly to html + Left err -> do -- html generation failed + let msg = "Notification failed for " <> tshow encRecipient <> ". HTML generation failed: "<> cropText err <> "For Notification: " <> tshow pjid + $logErrorS "LETTER" msg + return False + Right html -> do -- html generated, send directly now + let isSupervised = recipient /= svr + -- subject = if isSupervised + -- then "[SUPERVISOR] " <> mailSubject + -- else mailSubject + subject = if isSupervised + then mailSupervisorSubject + else mailSubject + userMailTdirect svr $ do + replaceMailHeader "Auto-Submitted" $ Just "auto-generated" + setSubjectI subject + -- when isSupervised $ mapSubject ("[SUPERVISOR] " <>) + addHtmlMarkdownAlternatives html + return True return $ or oks diff --git a/src/Utils/Print/ExpireQualification.hs b/src/Utils/Print/ExpireQualification.hs index c7f5e8167..fef6407e4 100644 --- a/src/Utils/Print/ExpireQualification.hs +++ b/src/Utils/Print/ExpireQualification.hs @@ -24,19 +24,21 @@ data LetterExpireQualificationF = LetterExpireQualificationF , leqfHolderID :: UserId , leqfHolderDN :: UserDisplayName , leqfHolderSN :: UserSurname - , leqfExpiry :: Day + , leqfExpiry :: Maybe Day , leqfId :: QualificationId , leqfName :: Text , leqfShort :: Text - , leqfSchool :: SchoolId + , leqfSchool :: SchoolId + , leqfUrl :: Maybe Text } deriving (Eq, Show) -- TODO: use markdown to generate the Letter instance MDMail LetterExpireQualificationF where + attachPDFLetter _ = False getMailSubject l = SomeMessage $ MsgMailSubjectQualificationExpired $ leqfShort l - getMailBody LetterExpireQualificationF{..} DateTimeFormatter{ format } = - let expiryDate = format SelFormatDate leqfExpiry + getMailBody LetterExpireQualificationF{..} DateTimeFormatter{ format } = return $ + let expiryDate = format SelFormatDate <$> leqfExpiry userDisplayName = leqfHolderDN userSurname = leqfHolderSN qualificationName = leqfName @@ -46,6 +48,12 @@ instance MDMail LetterExpireQualificationF where ihamletSomeMessage _ _ _ = (mempty :: Html) -- TODO: use markdown for letter editNotifications = () -- TODO: use markdown for letter in $(ihamletFile "templates/mail/qualificationExpired.hamlet") + -- const $ const html + -- Html -> HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX) + -- foo _ _ html -> html + -- [shamlet|#Ansprache #{html}|] um Html umzuwandeln! + -- + instance MDLetter LetterExpireQualificationF where encryptPDFfor _ = NoPassword @@ -63,7 +71,8 @@ instance MDLetter LetterExpireQualificationF where ] <> [ toMeta "lang" lang , toMeta "licenceholder" leqfHolderDN - , toMeta "expiry" (format SelFormatDate leqfExpiry) + , mbMeta "expiry" (format SelFormatDate <$> leqfExpiry) + , mbMeta "licence-url" leqfUrl ] getPJId LetterExpireQualificationF{..} = diff --git a/src/Utils/Print/Letters.hs b/src/Utils/Print/Letters.hs index 22ad52518..d3cd2ccb4 100644 --- a/src/Utils/Print/Letters.hs +++ b/src/Utils/Print/Letters.hs @@ -152,6 +152,9 @@ paperKind Plain = "a4wht" -- Ohne Logo paperKind Din5008 = "a4log" -- Mit Logo paperKind PlainLogo = "a4log" +templateHtml :: LetterKind -> Text +-- templateHtml Din5008 = decodeUtf8 $(Data.FileEmbed.embedFile "templates/letter/generic_template.html") +templateHtml _ = decodeUtf8 $(Data.FileEmbed.embedFile "templates/letter/generic_template.html") --------------- @@ -217,7 +220,7 @@ data EncryptPDFfor = NoPassword | PasswordSupervisor | PasswordUnderling class MDLetter l where letterMeta :: l -> DateTimeFormatter -> Lang -> Entity User -> P.Meta -- formatter/lang for individual receiver, set Meta "lang" for individually translated letters - -- NOTE: METAs "date", "rcvr-name", "address" are set automatically by renderLetter for each receiver + -- NOTE: METAs "date", "rcvr-name", "address" are set automatically by renderLetterPDF for each receiver getPJId :: l -> PrintJobIdentification getLetterEnvelope :: l -> Char getLetterKind :: l -> LetterKind @@ -249,4 +252,7 @@ getApcIdent _ = Nothing class MDMail l where -- getMailSubject :: l -> SomeMessage UniWorX -- only used if letter is sent by email as pdf attachment - getMailBody :: l -> DateTimeFormatter -> HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX) -- only used if letter is sent by email as pdf attachment + getMailBody :: (MonadHandler m) => l -> DateTimeFormatter -> m (HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX)) -- only used if letter is sent by email as pdf attachment + -- | should the email also contain the letter as a PDF attachment? + attachPDFLetter :: l -> Bool + attachPDFLetter = const True diff --git a/src/Utils/Print/RenewQualification.hs b/src/Utils/Print/RenewQualification.hs index fc6a05038..a7900105c 100644 --- a/src/Utils/Print/RenewQualification.hs +++ b/src/Utils/Print/RenewQualification.hs @@ -48,7 +48,7 @@ letterRenewalQualificationFData LetterRenewQualificationF{lmsLogin} = LetterRene instance MDMail LetterRenewQualificationF where getMailSubject l = SomeMessage $ MsgMailSubjectQualificationRenewal $ qualShort l - getMailBody l@LetterRenewQualificationF{..} DateTimeFormatter{ format } = + getMailBody l@LetterRenewQualificationF{..} DateTimeFormatter{ format } = return $ let LetterRenewQualificationFData{..} = letterRenewalQualificationFData l in $(ihamletFile "templates/mail/body/qualificationRenewal.hamlet") diff --git a/templates/letter/fraport_f_expiry.md b/templates/letter/fraport_f_expiry.md index 8cb3768e5..8df73e7ea 100644 --- a/templates/letter/fraport_f_expiry.md +++ b/templates/letter/fraport_f_expiry.md @@ -4,7 +4,7 @@ de-subject: 'Entzug "F" (Vorfeldführerschein)' en-subject: Revocation of apron driving license author: Fraport AG - Fahrerausbildung (AVN-AR) -phone: +49 69 690-28467 +phone: +49 69 690-30306 email: fahrerausbildung@fraport.de place: Frankfurt am Main return-address: @@ -22,7 +22,6 @@ hyperrefoptions: hidelinks ### Metadaten, welche automatisch ersetzt werden: date: 11.11.1111 -expiry: 00.00.0000 lang: de-de is-de: true # Emfpänger @@ -58,11 +57,20 @@ den Wissenstest im Rahmen des Recurrent Trainings Vorfeldführerschein nicht bes oder die Ablauffrist nicht eingehalten. -Die Qualifikation „Vorfeldführerschein“ ist somit nicht mehr gültig. +Die Qualifikation „Vorfeldführerschein“ ist somit +$if(expiry)$ + seit $expiry$ +$endif$ +nicht mehr gültig. $if(supervisor)$ -$licenceholder$ darf +$if(licence-url)$ +[$licenceholder$]($licence-url$) +$else$ +$licenceholder$ +$endif$ +darf $else$ Sie dürfen $endif$ @@ -80,7 +88,7 @@ Telefon Email - : $email$ + : [$email$](mailto:$email$) $else$ Hierfür wenden Sie sich bitte an Ihren Arbeitgeber. @@ -98,11 +106,19 @@ did not pass the required knowledge test within the allotted time for the renewal of the apron driving licence. -The qualification „Vorfeldführerschein“ (apron driving lincence) is therefore invalid now. - +The qualification „Vorfeldführerschein“ (apron driving lincence) is therefore invalid +$if(expiry)$ + since $expiry$. +$else$ + now. +$endif$ $if(supervisor)$ - $licenceholder$ +$if(licence-url)$ +[$licenceholder$]($licence-url$) +$else$ +$licenceholder$ +$endif$ $else$ You $endif$ @@ -121,7 +137,7 @@ Phone Email - : $email$ + : [$email$](mailto:$email$) $else$ Please contact your employer to book a course for you. diff --git a/templates/letter/generic_template.html b/templates/letter/generic_template.html new file mode 100644 index 000000000..4a752f3e8 --- /dev/null +++ b/templates/letter/generic_template.html @@ -0,0 +1,262 @@ + + + + + + + + $for(author-meta)$ $endfor$ + $if(date-meta)$ $endif$ + $if(keywords)$ + $endif$ + $if(title-prefix)$$title-prefix$ \8211 $endif$$pagetitle$ + + $for(css)$ $endfor$ + $if(math)$ $math$ $endif$ + + $for(header-includes)$ $header-includes$ $endfor$ + + + + $for(include-before)$ $include-before$ $endfor$ + $if(title)$
+

$title$

$if(subtitle)$

$subtitle$

$endif$ $for(author)$

$author$

$endfor$ $if(date)$

$date$

$endif$ +
+ $endif$ + $if(toc)$ + $endif$ + + $if(is-de)$ $de-opening$ $else$ $en-opening$ $endif$ + $body$ + $if(is-de)$ $de-closing$ $else$ $en-closing$ $endif$ + + $for(include-after)$ $include-after$ $endfor$ + + + \ No newline at end of file diff --git a/templates/mail/qualificationExpired.hamlet b/templates/mail/qualificationExpired.hamlet index a8ba9c974..a7d84f549 100644 --- a/templates/mail/qualificationExpired.hamlet +++ b/templates/mail/qualificationExpired.hamlet @@ -29,8 +29,9 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later #{qualificationName}
_{SomeMessage MsgLmsUser}
#{nameHtml userDisplayName userSurname} -
_{SomeMessage MsgQualificationExpired} -
#{expiryDate} + $maybe expDate <- expiryDate +
_{SomeMessage MsgQualificationExpired} +
#{expDate} ^{ihamletSomeMessage editNotifications} diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index d165ed9fc..c26576ef1 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -691,23 +691,23 @@ fillDb = do qid_f <- insert' $ Qualification avn "F" "Vorfeldführerschein" f_descr (Just 24) (Just 6) (Just $ CalendarDiffDays 0 60) True (Just AvsLicenceVorfeld) $ Just "F4466" qid_r <- insert' $ Qualification avn "R" "Rollfeldführerschein" r_descr (Just 12) (Just 6) (Just $ CalendarDiffDays 2 3) False (Just AvsLicenceRollfeld) $ Just "R2801" qid_l <- insert' $ Qualification ifi "L" "Lehrbefähigung" l_descr Nothing (Just 6) Nothing True Nothing Nothing - void . insert' $ QualificationUser jost qid_f (n_day 9) (n_day $ -1) (n_day $ -22) (Just $ QualificationBlocked (n_day $ -5) "LMS") True -- TODO: better dates! - void . insert' $ QualificationUser jost qid_r (n_day 99) (n_day $ -11) (n_day $ -222) Nothing True -- TODO: better dates! - void . insert' $ QualificationUser jost qid_l (n_day 999) (n_day $ -111) (n_day $ -2222) Nothing True -- TODO: better dates! - void . insert' $ QualificationUser gkleen qid_f (n_day $ -3) (n_day $ -4) (n_day $ -20) Nothing True - void . insert' $ QualificationUser maxMuster qid_f (n_day 0) (n_day $ -2) (n_day $ -8) Nothing False - void . insert' $ QualificationUser svaupel qid_f (n_day 1) (n_day $ -1) (n_day $ -2) Nothing True - void . insert' $ QualificationUser sbarth qid_f (n_day 400) (n_day $ -40) (n_day $ -1200) Nothing True - void . insert' $ QualificationUser tinaTester qid_f (n_day 3) (n_day $ -60) (n_day $ -250) (Just $ QualificationBlocked (n_day $ -7) "Some long explanation for the block!") False - void . insert' $ QualificationUser tinaTester qid_r (n_day 3) (n_day $ -60) (n_day $ -250) Nothing False - void . insert' $ QualificationUser gkleen qid_r (n_day $ -7) (n_day $ -2) (n_day $ -9) Nothing True - void . insert' $ QualificationUser maxMuster qid_r (n_day 1) (n_day $ -1) (n_day $ -2) Nothing False - -- void . insert' $ QualificationUser fhamann qid_r (n_day $ -3) (n_day $ -1) (n_day $ -2) Nothing True - void . insert' $ QualificationUser svaupel qid_l (n_day 1) (n_day $ -1) (n_day $ -2) Nothing True - void . insert' $ QualificationUser gkleen qid_l (n_day 9) (n_day $ -1) (n_day $ -7) Nothing True + void . insert' $ QualificationUser jost qid_f (n_day 9) (n_day $ -1) (n_day $ -22) (Just $ QualificationBlocked (n_day $ -5) "LMS") True (n_day' $ -9) -- TODO: better dates! + void . insert' $ QualificationUser jost qid_r (n_day 99) (n_day $ -11) (n_day $ -222) Nothing True (n_day' $ -9) -- TODO: better dates! + void . insert' $ QualificationUser jost qid_l (n_day 999) (n_day $ -111) (n_day $ -2222) Nothing True (n_day' $ -9) -- TODO: better dates! + void . insert' $ QualificationUser gkleen qid_f (n_day $ -3) (n_day $ -4) (n_day $ -20) Nothing True (n_day' $ -9) + void . insert' $ QualificationUser maxMuster qid_f (n_day 0) (n_day $ -2) (n_day $ -8) Nothing False (n_day' $ -1) + void . insert' $ QualificationUser svaupel qid_f (n_day 1) (n_day $ -1) (n_day $ -2) Nothing True (n_day' $ -9) + void . insert' $ QualificationUser sbarth qid_f (n_day 400) (n_day $ -40) (n_day $ -1200) Nothing True (n_day' $ -2) + void . insert' $ QualificationUser tinaTester qid_f (n_day 3) (n_day $ -60) (n_day $ -250) (Just $ QualificationBlocked (n_day $ -7) "Some long explanation for the block!") False (n_day' $ -9) + void . insert' $ QualificationUser tinaTester qid_r (n_day 3) (n_day $ -60) (n_day $ -250) Nothing False (n_day' $ -3) + void . insert' $ QualificationUser gkleen qid_r (n_day $ -7) (n_day $ -2) (n_day $ -9) Nothing True (n_day' $ -4) + void . insert' $ QualificationUser maxMuster qid_r (n_day 1) (n_day $ -1) (n_day $ -2) Nothing False (n_day' $ -6) + -- void . insert' $ QualificationUser fhamann qid_r (n_day $ -3) (n_day $ -1) (n_day $ -2) Nothing True (n_day' $ -9) + void . insert' $ QualificationUser svaupel qid_l (n_day 1) (n_day $ -1) (n_day $ -2) Nothing True (n_day' $ -7) + void . insert' $ QualificationUser gkleen qid_l (n_day 9) (n_day $ -1) (n_day $ -7) Nothing True (n_day' $ -8) qidfUsers <- Set.fromAscList . fmap (qualificationUserUser . entityVal) <$> selectList [QualificationUserQualification ==. qid_f] [Asc QualificationUserUser] - insertMany_ [QualificationUser uid qid_f (n_day 42) (n_day $ -42) (n_day $ -365) Nothing True | Entity uid _ <- take 200 matUsers, uid `Set.notMember` qidfUsers] + insertMany_ [QualificationUser uid qid_f (n_day 42) (n_day $ -42) (n_day $ -365) Nothing True (n_day' $ -11)| Entity uid _ <- take 200 matUsers, uid `Set.notMember` qidfUsers] void . insert' $ LmsResult qid_f (LmsIdent "hijklmn") (n_day (-1)) now void . insert' $ LmsResult qid_f (LmsIdent "opqgrs" ) (n_day (-2)) now void . insert' $ LmsResult qid_f (LmsIdent "pqgrst" ) (n_day (-3)) now