diff --git a/TODO.md b/TODO.md new file mode 100644 index 000000000..18b324a8b --- /dev/null +++ b/TODO.md @@ -0,0 +1,15 @@ +# Incomplete Files +These files just contain + - calls to error or + - just consist of stubs or + - use misplaced placeholders from other sources +and need to be finished. + +## Modules: + - Handler.Qualification + - Jobs.Handler.SendNotification.Qualification +## Files: + - templates/mail/qualificationExpiry.hamlet + - templates/i18n/qualification/renewal/de-de-formal.hamlet + - templates/i18n/qualification/renewal/en-eu.hamlet + \ 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 5095dfef3..10435f453 100644 --- a/messages/uniworx/categories/qualification/de-de-formal.msg +++ b/messages/uniworx/categories/qualification/de-de-formal.msg @@ -41,4 +41,6 @@ LmsResultUpdate: LMS Ergebnis aktualisierung LmsResultCsvExceptionDuplicatedKey: CSV Import fand uneindeutigen Schlüssel LmsUserlistCsvExceptionDuplicatedKey: CSV Import fand uneindeutigen Schlüssel LmsDirectUpload: Direkter Upload für automatisierte Systeme -LmsErrorNoRefreshElearning: Fehler: E-Lernen wird nicht automatisch gestartet, da die Zeitspanne für den Erneurerungszeitraum nicht festgelegt wurde. \ No newline at end of file +LmsErrorNoRefreshElearning: Fehler: E-Lernen wird nicht automatisch gestartet, da die Zeitspanne für den Erneurerungszeitraum nicht festgelegt wurde. +MailSubjectQualificationRenewal qname@Text: Ihre Qualifikation #{qname} muss demnächst erneuert werden +MailSubjectQualificationExpiry qname@Text: Ihre Qualifikation #{qname} läuft demnächst ab diff --git a/messages/uniworx/categories/qualification/en-eu.msg b/messages/uniworx/categories/qualification/en-eu.msg index 6347658a3..ae3556311 100644 --- a/messages/uniworx/categories/qualification/en-eu.msg +++ b/messages/uniworx/categories/qualification/en-eu.msg @@ -41,4 +41,6 @@ LmsResultUpdate: Update of LMS result LmsResultCsvExceptionDuplicatedKey: CSV import with ambiguous key LmsUserlistCsvExceptionDuplicatedKey: CSV import with ambiguous key LmsDirectUpload: Direct upload for automated Systems -LmsErrorNoRefreshElearning: Error: E-learning will not be started automatically due to refresh-within time period not being set. \ No newline at end of file +LmsErrorNoRefreshElearning: Error: E-learning will not be started automatically due to refresh-within time period not being set. +MailSubjectQualificationRenewal qname@Text: Your qualification #{qname} must be renewed shortly +MailSubjectQualificationExpiry qname@Text: Your qualification #{qname} expires soon diff --git a/routes b/routes index 7a139cd2c..93b67e0b0 100644 --- a/routes +++ b/routes @@ -254,16 +254,20 @@ !/*WellKnownFileName WellKnownR GET !free +-- for users +/qualification QualificationAllR GET !free +/qualification/#SchoolId QualificationSchoolR GET !free +/qualification/#SchoolId/#QualificationShorthand QualificationR GET !free -- must be logged in though -- OSIS CSV Export Demo -/lms LmsAllR GET -/lms/#SchoolId LmsSchoolR GET -/lms/#SchoolId/#QualificationShorthand LmsR GET POST -/lms/#SchoolId/#QualificationShorthand/edit LmsEditR GET POST -/lms/#SchoolId/#QualificationShorthand/users LmsUsersR GET -/lms/#SchoolId/#QualificationShorthand/users/direct LmsUsersDirectR GET -/lms/#SchoolId/#QualificationShorthand/userlist LmsUserlistR GET POST -/lms/#SchoolId/#QualificationShorthand/userlist/upload LmsUserlistUploadR GET POST -/lms/#SchoolId/#QualificationShorthand/userlist/direct LmsUserlistDirectR POST -/lms/#SchoolId/#QualificationShorthand/result LmsResultR GET POST -/lms/#SchoolId/#QualificationShorthand/result/upload LmsResultUploadR GET POST -/lms/#SchoolId/#QualificationShorthand/result/direct LmsResultDirectR POST +/lms LmsAllR GET +/lms/#SchoolId LmsSchoolR GET +/lms/#SchoolId/#QualificationShorthand LmsR GET POST +/lms/#SchoolId/#QualificationShorthand/edit LmsEditR GET POST +/lms/#SchoolId/#QualificationShorthand/users LmsUsersR GET +/lms/#SchoolId/#QualificationShorthand/users/direct LmsUsersDirectR GET +/lms/#SchoolId/#QualificationShorthand/userlist LmsUserlistR GET POST +/lms/#SchoolId/#QualificationShorthand/userlist/upload LmsUserlistUploadR GET POST +/lms/#SchoolId/#QualificationShorthand/userlist/direct LmsUserlistDirectR POST +/lms/#SchoolId/#QualificationShorthand/result LmsResultR GET POST +/lms/#SchoolId/#QualificationShorthand/result/upload LmsResultUploadR GET POST +/lms/#SchoolId/#QualificationShorthand/result/direct LmsResultDirectR POST diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index ebec4d9e3..6cf128d4f 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -133,7 +133,15 @@ breadcrumb HealthR = i18nCrumb MsgMenuHealth Nothing breadcrumb InstanceR = i18nCrumb MsgMenuInstance Nothing breadcrumb StatusR = i18nCrumb MsgMenuHealth Nothing -- never displayed -breadcrumb LmsAllR = i18nCrumb MsgMenuQualifications Nothing +breadcrumb QualificationAllR = i18nCrumb MsgMenuQualifications Nothing +breadcrumb (QualificationSchoolR ssh ) = useRunDB . maybeT (i18nCrumb MsgBreadcrumbSchool . Just $ SchoolListR) $ do -- redirect only, used in other breadcrumbs + guardM . lift . existsBy . UniqueSchoolShorthand $ unSchoolKey ssh + return (CI.original $ unSchoolKey ssh, Just QualificationAllR) +breadcrumb (QualificationR ssh qsh) =useRunDB . maybeT (i18nCrumb MsgBreadcrumbCourse . Just $ QualificationSchoolR ssh) $ do + guardM . lift . existsBy $ SchoolQualificationShort ssh qsh + return (CI.original qsh, Just $ QualificationSchoolR ssh) + +breadcrumb LmsAllR = i18nCrumb MsgMenuLms Nothing breadcrumb (LmsSchoolR ssh ) = useRunDB . maybeT (i18nCrumb MsgBreadcrumbSchool . Just $ SchoolListR) $ do -- redirect only, used in other breadcrumbs guardM . lift . existsBy . UniqueSchoolShorthand $ unSchoolKey ssh return (CI.original $ unSchoolKey ssh, Just LmsAllR) diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs new file mode 100644 index 000000000..ad321b2b4 --- /dev/null +++ b/src/Handler/Qualification.hs @@ -0,0 +1,248 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} -- needed for HasEntity instances +{-# OPTIONS -Wno-unused-top-binds #-} -- TODO: remove me, for debugging only +{-# LANGUAGE TypeApplications #-} + +module Handler.Qualification + ( getQualificationAllR + , getQualificationSchoolR + , getQualificationR + ) + where + +import Import + +import Handler.Utils +-- import Handler.Utils.Csv +-- import Handler.Utils.LMS + +import qualified Data.Map as Map +-- import qualified Data.Csv as Csv +-- import qualified Data.Conduit.List as C +import qualified Database.Esqueleto.Experimental as Ex -- needs TypeApplications Lang-Pragma +import qualified Database.Esqueleto.Legacy as E +import qualified Database.Esqueleto.Utils as E +import Database.Esqueleto.Utils.TH + + +-- avoids repetition of local definitions +single :: (k,a) -> Map k a +single = uncurry Map.singleton + +getQualificationSchoolR :: SchoolId -> Handler Html +getQualificationSchoolR ssh = redirect (QualificationAllR, [("qualification-overview-school", toPathPiece ssh)]) + +getQualificationAllR :: Handler Html +getQualificationAllR = do -- TODO just a stub + lmsTable <- runDB $ do + view _2 <$> mkLmsAllTable + siteLayoutMsg MsgMenuQualifications $ do + setTitleI MsgMenuQualifications + $(widgetFile "lms-all") + +type AllQualificationTableData = DBRow (Entity Qualification, Ex.Value Word64, Ex.Value Word64) +resultAllQualification :: Lens' AllQualificationTableData Qualification +resultAllQualification = _dbrOutput . _1 . _entityVal + +resultAllQualificationActive :: Lens' AllQualificationTableData Word64 +resultAllQualificationActive = _dbrOutput . _2 . _unValue + +resultAllQualificationTotal :: Lens' AllQualificationTableData Word64 +resultAllQualificationTotal = _dbrOutput . _3 . _unValue + + +mkLmsAllTable :: DB (Any, Widget) +mkLmsAllTable = do + now <- liftIO getCurrentTime + let + resultDBTable = DBTable{..} + where + dbtSQLQuery quali = do + cusers <- pure . Ex.subSelectCount $ do + quser <- Ex.from $ Ex.table @QualificationUser + Ex.where_ $ quser Ex.^. QualificationUserQualification Ex.==. quali Ex.^. QualificationId + cactive <- pure . Ex.subSelectCount $ do + quser <- Ex.from $ Ex.table @QualificationUser + Ex.where_ $ quser Ex.^. QualificationUserQualification Ex.==. quali Ex.^. QualificationId + E.&&. quser Ex.^. QualificationUserValidUntil Ex.>=. E.val (utctDay now) + -- Failed attempt using Join/GroupBy instead of subselect: see branch csv-osis-demo-groupby-problem + return (quali, cactive, cusers) + dbtRowKey = (E.^. QualificationId) + dbtProj = dbtProjFilteredPostId -- TODO: or dbtProjSimple what is the difference? + dbtColonnade = dbColonnade $ mconcat + [ colSchool $ resultAllQualification . _qualificationSchool + , sortable (Just "qshort") (i18nCell MsgQualificationShort) $ \(view resultAllQualification -> quali) -> + let qsh = qualificationShorthand quali in + anchorCell (LmsR (qualificationSchool quali) qsh) $ toWgt qsh + , sortable (Just "qname") (i18nCell MsgQualificationName) $ \(view resultAllQualification -> quali) -> + let qsh = qualificationShorthand quali + qnm = qualificationName quali + in anchorCell (LmsR (qualificationSchool quali) qsh) $ toWgt qnm + , sortable Nothing (i18nCell MsgQualificationDescription) $ \(view resultAllQualification -> quali) -> + maybeCell (qualificationDescription quali) markupCellLargeModal + , sortable Nothing (i18nCell MsgQualificationValidDuration & cellTooltip MsgTableDiffDaysTooltip) $ + foldMap (textCell . formatCalendarDiffDays . fromMonths) . view (resultAllQualification . _qualificationValidDuration) + , sortable Nothing (i18nCell MsgQualificationRefreshWithin & cellTooltip MsgTableDiffDaysTooltip) $ + foldMap (textCell . formatCalendarDiffDays ) . view (resultAllQualification . _qualificationRefreshWithin) + -- , sortable Nothing (i18nCell MsgQualificationRefreshWithin) $ foldMap textCell . view (resultAllQualification . _qualificationRefreshWithin . to formatCalendarDiffDays) -- does not work, since there is a maybe in between + , sortable (Just "qelearning") (i18nCell MsgTableLmsElearning & cellTooltip MsgQualificationElearningStart) + $ tickmarkCell . view (resultAllQualification . _qualificationElearningStart) + , sortable Nothing (i18nCell MsgTableQualificationCountActive & cellTooltip MsgTableQualificationCountActiveTooltip) + $ \(view resultAllQualificationActive -> n) -> wgtCell $ word2widget n + , sortable Nothing (i18nCell MsgTableQualificationCountTotal) $ wgtCell . word2widget . view resultAllQualificationTotal + -- \(view resultAllQualificationTotal -> n) -> wgtCell $ word2widget n + ] + dbtSorting = mconcat + [ + sortSchool $ to (E.^. QualificationSchool) + , singletonMap "qshort" $ SortColumn (E.^. QualificationShorthand) + , singletonMap "qname" $ SortColumn (E.^. QualificationName) + , singletonMap "qelearning" $ SortColumn (E.^. QualificationElearningStart) + ] + dbtFilter = mconcat + [ + fltrSchool $ to (E.^. QualificationSchool) + , singletonMap "qelearning" . FilterColumn $ E.mkExactFilterLast (E.^. QualificationElearningStart) + ] + dbtFilterUI = mconcat + [ + fltrSchoolUI + , \mPrev -> prismAForm (singletonFilter "qelearning" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgTableLmsElearning) + ] + dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } + dbtParams = def + dbtIdent :: Text + dbtIdent = "qualification-overview" + dbtCsvEncode = noCsvEncode + dbtCsvDecode = Nothing + dbtExtraReps = [] + + resultDBTableValidator = def + & defaultSorting [SortAscBy "school", SortAscBy "qshort"] + dbTable resultDBTableValidator resultDBTable + + + +getQualificationEditR, postQualificationEditR :: SchoolId -> QualificationShorthand -> Handler Html +getQualificationEditR = postQualificationEditR +postQualificationEditR = error "TODO" + + +type LmsTableExpr = ( E.SqlExpr (Entity QualificationUser) + `E.InnerJoin` E.SqlExpr (Entity User) + ) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity LmsUser)) + +queryQualUser :: LmsTableExpr -> E.SqlExpr (Entity QualificationUser) +queryQualUser = $(sqlIJproj 2 1) . $(sqlLOJproj 2 1) + +queryUser :: LmsTableExpr -> E.SqlExpr (Entity User) +queryUser = $(sqlIJproj 2 2) . $(sqlLOJproj 2 1) + +queryLmsUser :: LmsTableExpr -> E.SqlExpr (Maybe (Entity LmsUser)) +queryLmsUser = $(sqlLOJproj 2 2) + +type LmsTableData = DBRow (Entity QualificationUser, Entity User, Maybe (Entity LmsUser)) + +resultQualUser :: Lens' LmsTableData (Entity QualificationUser) +resultQualUser = _dbrOutput . _1 + +resultUser :: Lens' LmsTableData (Entity User) +resultUser = _dbrOutput . _2 + +resultLmsUser :: Traversal' LmsTableData (Entity LmsUser) +resultLmsUser = _dbrOutput . _3 . _Just + +instance HasEntity LmsTableData User where + hasEntity = resultUser + +instance HasUser LmsTableData where + hasUser = resultUser . _entityVal + +mkLmsTable :: Entity Qualification -> DB (Any, Widget) +mkLmsTable (Entity qid quali) = do + now <- liftIO getCurrentTime + let + nowaday = utctDay now + mbRenewal = addGregorianDurationClip <$> qualificationRefreshWithin quali <*> Just nowaday + resultDBTable = DBTable{..} + where + dbtSQLQuery = runReaderT $ do + qualUser <- asks queryQualUser + user <- asks queryUser + lmsUser <- asks queryLmsUser + lift $ do + E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser + E.on $ user E.^. UserId E.=?. lmsUser E.?. LmsUserUser + E.&&. E.val qid E.=?. lmsUser E.?. LmsUserQualification + E.where_ $ E.val qid E.==. qualUser E.^. QualificationUserQualification + return (qualUser, user, lmsUser) + dbtRowKey = queryUser >>> (E.^. UserId) + dbtProj = dbtProjFilteredPostId -- TODO: or dbtProjSimple what is the difference? + dbtColonnade = dbColonnade $ mconcat + [ colUserNameLinkHdr MsgTableLmsUser AdminUserR + , colUserEmail + , sortable (Just "valid-until") (i18nCell MsgTableQualificationValidUntil) $ \( view $ resultQualUser . _entityVal . _qualificationUserValidUntil -> d) -> dayCell d + , sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \( view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> dayCell d + , sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \( view $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> dayCell d + , sortable (Just "lms-ident") (i18nLms MsgTableLmsIdent) $ \(preview $ resultLmsUser . _entityVal . _lmsUserIdent . _getLmsIdent -> lid) -> foldMap textCell lid + , sortable (Just "lms-status") (i18nLms MsgTableLmsStatus) $ \(preview $ resultLmsUser . _entityVal . _lmsUserStatus -> status) -> foldMap lmsStatusCell $ join status + , sortable (Just "lms-started") (i18nLms MsgTableLmsStarted) $ \(preview $ resultLmsUser . _entityVal . _lmsUserStarted -> d) -> foldMap dateTimeCell d + , sortable (Just "lms-received") (i18nLms MsgTableLmsReceived) $ \(preview $ resultLmsUser . _entityVal . _lmsUserReceived -> d) -> foldMap dateTimeCell $ join d + , sortable (Just "lms-ended") (i18nLms MsgTableLmsEnded) $ \(preview $ resultLmsUser . _entityVal . _lmsUserEnded -> d) -> foldMap dateTimeCell $ join d + ] + where + i18nLms :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a + i18nLms msg = cell [whamlet|LMS #|] <> i18nCell msg + dbtSorting = mconcat + [ single $ sortUserNameLink queryUser + , single $ sortUserEmail queryUser + , single ("valid-until" , SortColumn $ queryQualUser >>> (E.^. QualificationUserValidUntil)) + , single ("last-refresh", SortColumn $ queryQualUser >>> (E.^. QualificationUserLastRefresh)) + , 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)) + , single ("lms-received", SortColumn $ queryLmsUser >>> (E.?. LmsUserReceived)) + , single ("lms-ended" , SortColumn $ queryLmsUser >>> (E.?. LmsUserEnded)) + ] + dbtFilter = mconcat + [ single $ fltrUserNameEmail queryUser + , single ("lms-ident" , FilterColumn . E.mkContainsFilterWith (Just . LmsIdent) $ views (to queryLmsUser) (E.?. LmsUserIdent)) + -- , single ("lms-status" , FilterColumn . E.mkExactFilterLast $ views (to queryLmsUser) ((E.>=. E.val nowaday) . (E.^. LmsUserStatus))) -- LmsStatus cannot be filtered easily within the DB + , single ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) ((E.>=. E.val nowaday) . (E.^. QualificationUserValidUntil))) + , single ("renewal-due" , FilterColumn $ \(view (to queryQualUser) -> quser) criterion -> + if | Just renewal <- mbRenewal + , Just True <- getLast criterion -> quser E.^. QualificationUserValidUntil E.<=. E.val renewal + E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val nowaday + | otherwise -> E.true + ) + ] + dbtFilterUI mPrev = mconcat + [ fltrUserNameEmailHdrUI MsgTableLmsUser mPrev + , prismAForm (singletonFilter "lms-ident" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent) + -- , prismAForm (singletonFilter "lms-status" . maybePrism _PathPiece) mPrev $ aopt (selectField' (Just $ SomeMessage MsgTableNoFilter) $ return (optionsPairs [(MsgTableLmsSuccess,"success"::Text),(MsgTableLmsFailed,"blocked")])) (fslI MsgTableLmsStatus) + , prismAForm (singletonFilter "validity" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsValid) + , if isNothing mbRenewal then mempty + else prismAForm (singletonFilter "renewal-due" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsRenewal) + ] + dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } + dbtParams = def + dbtIdent :: Text + dbtIdent = "qualification" + dbtCsvEncode = noCsvEncode + dbtCsvDecode = Nothing + dbtExtraReps = [] + + resultDBTableValidator = def + -- & defaultSorting [SortAscBy csvLmsIdent] + dbTable resultDBTableValidator resultDBTable + +getQualificationR :: SchoolId -> QualificationShorthand -> Handler Html +getQualificationR sid qsh = do -- TODO just a copied stub + (lmsTable, quali) <- runDB $ do + qent@(Entity _qid quali) <- getBy404 $ SchoolQualificationShort sid qsh + tbl <- view _2 <$> mkLmsTable qent + return (tbl, quali) + let heading = citext2widget $ qualificationName quali + siteLayout heading $ do + setTitle $ toHtml $ unSchoolKey sid <> "-" <> qsh + $(widgetFile "lms") diff --git a/src/Handler/Utils/I18n.hs b/src/Handler/Utils/I18n.hs index 3718958a0..cf66259df 100644 --- a/src/Handler/Utils/I18n.hs +++ b/src/Handler/Utils/I18n.hs @@ -58,7 +58,7 @@ i18nWidgetFile :: FilePath -> Q Exp i18nWidgetFile = i18nFile widgetFile i18nHamletFile :: FilePath -> Q Exp -i18nHamletFile basename = [e|$(i18nFile (hamletFile . (<.> "hamlet")) basename) <$> getUrlRenderParams|] +i18nHamletFile basename = [e|$(i18nFile (hamletFile . ("templates" ) . (<.> "hamlet")) basename) <$> getUrlRenderParams|] i18nWidgetFiles :: FilePath -> Q Exp i18nWidgetFiles basename = do diff --git a/src/Jobs/Handler/SendNotification/Qualification.hs b/src/Jobs/Handler/SendNotification/Qualification.hs index 333b46478..10efb99c0 100644 --- a/src/Jobs/Handler/SendNotification/Qualification.hs +++ b/src/Jobs/Handler/SendNotification/Qualification.hs @@ -7,43 +7,45 @@ module Jobs.Handler.SendNotification.Qualification import Import -{- + import Handler.Utils import Jobs.Handler.SendNotification.Utils -import Handler.Info (FAQItem(..)) - +-- import Handler.Info (FAQItem(..)) +import qualified Data.CaseInsensitive as CI import Text.Hamlet -import qualified Database.Esqueleto.Experimental as E -import qualified Database.Esqueleto.Utils as E --} +-- import qualified Database.Esqueleto.Experimental as E +-- import qualified Database.Esqueleto.Utils as E + dispatchNotificationQualificationExpiry :: QualificationId -> Day -> UserId -> Handler () -dispatchNotificationQualificationExpiry _nQualification _nExpiry _jRecipient = - error "dispatchNotificationQualificationExpiry not yet implemented TODO" -{- userMailT jRecipient $ do - (Allocation{..}, Course{..}, hasApplied) <- liftHandler . runDB $ (,,) - <$> getJust nAllocation - <*> getJust nCourse - <*> exists [CourseApplicationAllocation ==. Just nAllocation, CourseApplicationUser ==. jRecipient] +dispatchNotificationQualificationExpiry nQualification _nExpiry jRecipient = userMailT jRecipient $ do + (User{..}, Qualification{..}, Entity _ QualificationUser{..}) <- liftHandler . runDB $ (,,) + <$> getJust jRecipient + <*> getJust nQualification + <*> getJustBy (UniqueQualificationUser nQualification jRecipient) + let qname = CI.original qualificationName replaceMailHeader "Auto-Submitted" $ Just "auto-generated" - setSubjectI $ MsgMailSubjectAllocationNewCourse allocationName + setSubjectI $ MsgMailSubjectQualificationExpiry qname + editNotifications <- mkEditNotifications jRecipient - cID <- encrypt nCourse - mayApply <- lift $ orM - [ is _Authorized <$> evalAccessFor (Just jRecipient) (AllocationR allocationTerm allocationSchool allocationShorthand ARegisterR) True - , is _Authorized <$> evalAccessFor (Just jRecipient) (AllocationR allocationTerm allocationSchool allocationShorthand $ AApplyR cID) True - ] + addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/qualificationExpiry.hamlet") - allocUrl <- toTextUrl $ AllocationR allocationTerm allocationSchool allocationShorthand AShowR :#: cID - - addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/allocationNewCourse.hamlet") --} dispatchNotificationQualificationRenewal :: QualificationId -> UserId -> Handler () -dispatchNotificationQualificationRenewal _nQualification _jRecipient = - error "dispatchNotificationQualificationRenewal not yet implemented TODO" - -- userMailT jRecipient $ do \ No newline at end of file +dispatchNotificationQualificationRenewal nQualification jRecipient = userMailT jRecipient $ do + (User{..}, Qualification{..}, Entity _ QualificationUser{..}) <- liftHandler . runDB $ (,,) + <$> getJust jRecipient + <*> getJust nQualification + <*> getJustBy (UniqueQualificationUser nQualification jRecipient) + + let qname = CI.original qualificationName + replaceMailHeader "Auto-Submitted" $ Just "auto-generated" + setSubjectI $ MsgMailSubjectQualificationRenewal qname + + -- editNotifications <- mkEditNotifications jRecipient -- TODO: add to hamlet file again + addHtmlMarkdownAlternatives $(i18nHamletFile "qualification/renewal") + \ No newline at end of file diff --git a/src/Settings.hs b/src/Settings.hs index b1cab0497..c4379d1be 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -747,6 +747,11 @@ widgetFile = widgetFileNoReload widgetFileSettings #endif +-- Since widgetFile above also add "templates" directory, requires import Text.Hamlet (hamletFile) +-- hamletFile' :: FilePath -> Q Exp +-- hamletFile' nameBase = hamletFile $ "templates" nameBase + + -- | Raw bytes at compile time of @config/settings.yml@ configSettingsYmlBS :: ByteString configSettingsYmlBS = $(embedFile configSettingsYml) diff --git a/templates/i18n/qualification/renewal/de-de-formal.hamlet b/templates/i18n/qualification/renewal/de-de-formal.hamlet new file mode 100644 index 000000000..997254103 --- /dev/null +++ b/templates/i18n/qualification/renewal/de-de-formal.hamlet @@ -0,0 +1,27 @@ +$newline never +\ + + + +