chore(lms): work on lms send notifications, work-in-progress
This commit is contained in:
Steffen Jost
parent
5c9a5206df
commit
e0c429cd1e
15
TODO.md
Normal file
15
TODO.md
Normal file
@ -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
|
||||
|
||||
@ -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.
|
||||
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
|
||||
|
||||
@ -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.
|
||||
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
|
||||
|
||||
28
routes
28
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
|
||||
|
||||
@ -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)
|
||||
|
||||
248
src/Handler/Qualification.hs
Normal file
248
src/Handler/Qualification.hs
Normal file
@ -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")
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
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")
|
||||
|
||||
@ -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)
|
||||
|
||||
27
templates/i18n/qualification/renewal/de-de-formal.hamlet
Normal file
27
templates/i18n/qualification/renewal/de-de-formal.hamlet
Normal file
@ -0,0 +1,27 @@
|
||||
$newline never
|
||||
\<!doctype html>
|
||||
<html>
|
||||
<head>
|
||||
<meta charset="UTF-8">
|
||||
<style>
|
||||
h1 {
|
||||
font-size: 1.25em;
|
||||
font-variant: small-caps;
|
||||
font-weight: normal;
|
||||
}
|
||||
<body>
|
||||
<h1>
|
||||
Qualifikation #{qualificationName} muss demnächst erneuert werden
|
||||
|
||||
<p>
|
||||
Ihre Qualifikation #{qualificationName} muss demnächst
|
||||
erneuert werden
|
||||
<br />
|
||||
<a href=@{QualificationR qualificationSchool qualificationShorthand}>
|
||||
#{qualificationName}
|
||||
|
||||
#{nameHtml userDisplayName userSurname}
|
||||
#{show qualificationUserValidUntil}
|
||||
#{show qualificationUserFirstHeld}
|
||||
|
||||
ihamletSomeMessage editNotifications
|
||||
27
templates/i18n/qualification/renewal/en-eu.hamlet
Normal file
27
templates/i18n/qualification/renewal/en-eu.hamlet
Normal file
@ -0,0 +1,27 @@
|
||||
$newline never
|
||||
\<!doctype html>
|
||||
<html>
|
||||
<head>
|
||||
<meta charset="UTF-8">
|
||||
<style>
|
||||
h1 {
|
||||
font-size: 1.25em;
|
||||
font-variant: small-caps;
|
||||
font-weight: normal;
|
||||
}
|
||||
<body>
|
||||
<h1>
|
||||
Qualification #{qualificationName} must be renewed shortly
|
||||
|
||||
<p>
|
||||
Your Qualification #{qualificationName} is about to expire.
|
||||
You may renew it to keep it:
|
||||
<br />
|
||||
<a href=@{QualificationR qualificationSchool qualificationShorthand}>
|
||||
#{qualificationName}
|
||||
|
||||
#{nameHtml userDisplayName userSurname}
|
||||
#{show qualificationUserValidUntil}
|
||||
#{show qualificationUserFirstHeld}
|
||||
|
||||
ihamletSomeMessage editNotifications
|
||||
26
templates/mail/qualificationExpiry.hamlet
Normal file
26
templates/mail/qualificationExpiry.hamlet
Normal file
@ -0,0 +1,26 @@
|
||||
$newline never
|
||||
\<!doctype html>
|
||||
<html>
|
||||
<head>
|
||||
<meta charset="UTF-8">
|
||||
<style>
|
||||
h1 {
|
||||
font-size: 1.25em;
|
||||
font-variant: small-caps;
|
||||
font-weight: normal;
|
||||
}
|
||||
<body>
|
||||
<h1>
|
||||
_{SomeMessage $ MsgMailSubjectQualificationExpiry qname}
|
||||
|
||||
<p>
|
||||
_{SomeMessage MsgMailAllocationNewCourseTip}
|
||||
<br />
|
||||
<a href=@{QualificationR qualificationSchool qualificationShorthand}>
|
||||
#{qualificationName}
|
||||
|
||||
#{nameHtml userDisplayName userSurname}
|
||||
#{show qualificationUserValidUntil}
|
||||
#{show qualificationUserFirstHeld}
|
||||
|
||||
^{ihamletSomeMessage editNotifications}
|
||||
Reference in New Issue
Block a user