fraport/fradrive-old
Archived
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

chore(lms): wip actions for lms table

Browse Source
This commit is contained in:
Steffen Jost 2022-05-18 18:11:47 +02:00
parent 458ad73670
commit a6ddbe7f08
3 changed files with 93 additions and 64 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
messages/uniworx/categories/qualification/de-de-formal.msg
View File

@ -45,3 +45,5 @@ LmsErrorNoRefreshElearning: Fehler: E-Lernen wird nicht automatisch gestartet, d
MailSubjectQualificationRenewal qname@Text: Ihre Qualifikation #{qname} muss demnächst erneuert werden MailSubjectQualificationRenewal qname@Text: Ihre Qualifikation #{qname} muss demnächst erneuert werden
MailSubjectQualificationExpiry qname@Text: Ihre Qualifikation #{qname} läuft demnächst ab MailSubjectQualificationExpiry qname@Text: Ihre Qualifikation #{qname} läuft demnächst ab
MailLmsRenewalBody: Sie müssen diese Qualifikaton demnächst durch einen E-Learning Kurs erneuern. MailLmsRenewalBody: Sie müssen diese Qualifikaton demnächst durch einen E-Learning Kurs erneuern.
LmsActNotify: Benachrichtigung E-Lernen erneut versenden
LmsActRenewPin: Neue zufällig E-Lernen PIN setzen

4
messages/uniworx/categories/qualification/en-eu.msg
View File

@ -44,4 +44,6 @@ 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 MailSubjectQualificationRenewal qname@Text: Your qualification #{qname} must be renewed shortly
MailSubjectQualificationExpiry qname@Text: Your qualification #{qname} expires soon MailSubjectQualificationExpiry qname@Text: Your qualification #{qname} expires soon
MailLmsRenewalBody: You will soon need to renew this qualficiation by completing an e-learning course. MailLmsRenewalBody: You will soon need to renew this qualficiation by completing an e-learning course.
LmsActNotify: Send e-learning notification again
LmsActRenewPin: Randomly replace e-learning PIN

151
src/Handler/LMS.hs
View File

@ -38,21 +38,21 @@ import Handler.LMS.Result as Handler.LMS
single :: (k,a) -> Map k a single :: (k,a) -> Map k a
single = uncurry Map.singleton single = uncurry Map.singleton
-- Button only needed here -- Button only needed here
data ButtonManualLms = LmsEnqueue | LmsDequeue data ButtonManualLms = LmsEnqueue | LmsDequeue
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable) deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
instance Universe ButtonManualLms instance Universe ButtonManualLms
instance Finite ButtonManualLms instance Finite ButtonManualLms
nullaryPathPiece ''ButtonManualLms camelToPathPiece nullaryPathPiece ''ButtonManualLms camelToPathPiece
instance Button UniWorX ButtonManualLms where instance Button UniWorX ButtonManualLms where
btnLabel LmsEnqueue = "Enqeue" btnLabel LmsEnqueue = "Enqeue"
btnLabel LmsDequeue = "Deqeue" btnLabel LmsDequeue = "Deqeue"
btnClasses LmsEnqueue = [BCIsButton, BCPrimary] btnClasses LmsEnqueue = [BCIsButton, BCPrimary]
btnClasses LmsDequeue = [BCIsButton, BCDefault] btnClasses LmsDequeue = [BCIsButton, BCDefault]
getLmsSchoolR :: SchoolId -> Handler Html getLmsSchoolR :: SchoolId -> Handler Html
getLmsSchoolR ssh = redirect (LmsAllR, [("qualification-overview-school", toPathPiece ssh)]) getLmsSchoolR ssh = redirect (LmsAllR, [("qualification-overview-school", toPathPiece ssh)])
@ -61,26 +61,26 @@ getLmsAllR, postLmsAllR :: Handler Html
getLmsAllR = postLmsAllR getLmsAllR = postLmsAllR
postLmsAllR = do postLmsAllR = do
((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm ("buttons" :: Text) (buttonForm :: Form ButtonManualLms) ((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm ("buttons" :: Text) (buttonForm :: Form ButtonManualLms)
let btnForm = wrapForm btnWdgt def let btnForm = wrapForm btnWdgt def
{ formAction = Just $ SomeRoute LmsAllR { formAction = Just $ SomeRoute LmsAllR
, formEncoding = btnEnctype , formEncoding = btnEnctype
, formSubmit = FormNoSubmit , formSubmit = FormNoSubmit
} }
case btnResult of case btnResult of
(FormSuccess LmsEnqueue) -> queueJob' JobLmsQualificationsEnqueue (FormSuccess LmsEnqueue) -> queueJob' JobLmsQualificationsEnqueue
(FormSuccess LmsDequeue) -> queueJob' JobLmsQualificationsDequeue (FormSuccess LmsDequeue) -> queueJob' JobLmsQualificationsDequeue
FormMissing -> return () FormMissing -> return ()
_other -> addMessage Warning "Kein korrekter LMS Knopf erkannt" _other -> addMessage Warning "Kein korrekter LMS Knopf erkannt"
lmsTable <- runDB $ do lmsTable <- runDB $ do
view _2 <$> mkLmsAllTable view _2 <$> mkLmsAllTable
siteLayoutMsg MsgMenuQualifications $ do siteLayoutMsg MsgMenuQualifications $ do
setTitleI MsgMenuQualifications setTitleI MsgMenuQualifications
$(widgetFile "lms-all") $(widgetFile "lms-all")
type AllQualificationTableData = DBRow (Entity Qualification, Ex.Value Word64, Ex.Value Word64) type AllQualificationTableData = DBRow (Entity Qualification, Ex.Value Word64, Ex.Value Word64)
resultAllQualification :: Lens' AllQualificationTableData Qualification resultAllQualification :: Lens' AllQualificationTableData Qualification
resultAllQualification = _dbrOutput . _1 . _entityVal resultAllQualification = _dbrOutput . _1 . _entityVal
resultAllQualificationActive :: Lens' AllQualificationTableData Word64 resultAllQualificationActive :: Lens' AllQualificationTableData Word64
resultAllQualificationActive = _dbrOutput . _2 . _unValue resultAllQualificationActive = _dbrOutput . _2 . _unValue
@ -90,46 +90,46 @@ resultAllQualificationTotal = _dbrOutput . _3 . _unValue
mkLmsAllTable :: DB (Any, Widget) mkLmsAllTable :: DB (Any, Widget)
mkLmsAllTable = do mkLmsAllTable = do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
let let
resultDBTable = DBTable{..} resultDBTable = DBTable{..}
where where
dbtSQLQuery quali = do dbtSQLQuery quali = do
cusers <- pure . Ex.subSelectCount $ do cusers <- pure . Ex.subSelectCount $ do
quser <- Ex.from $ Ex.table @QualificationUser quser <- Ex.from $ Ex.table @QualificationUser
Ex.where_ $ quser Ex.^. QualificationUserQualification Ex.==. quali Ex.^. QualificationId Ex.where_ $ quser Ex.^. QualificationUserQualification Ex.==. quali Ex.^. QualificationId
cactive <- pure . Ex.subSelectCount $ do cactive <- pure . Ex.subSelectCount $ do
quser <- Ex.from $ Ex.table @QualificationUser quser <- Ex.from $ Ex.table @QualificationUser
Ex.where_ $ quser Ex.^. QualificationUserQualification Ex.==. quali Ex.^. QualificationId Ex.where_ $ quser Ex.^. QualificationUserQualification Ex.==. quali Ex.^. QualificationId
E.&&. quser Ex.^. QualificationUserValidUntil Ex.>=. E.val (utctDay now) E.&&. quser Ex.^. QualificationUserValidUntil Ex.>=. E.val (utctDay now)
-- Failed attempt using Join/GroupBy instead of subselect: see branch csv-osis-demo-groupby-problem -- Failed attempt using Join/GroupBy instead of subselect: see branch csv-osis-demo-groupby-problem
return (quali, cactive, cusers) return (quali, cactive, cusers)
dbtRowKey = (E.^. QualificationId) dbtRowKey = (E.^. QualificationId)
dbtProj = dbtProjFilteredPostId -- TODO: or dbtProjSimple what is the difference? dbtProj = dbtProjFilteredPostId -- TODO: or dbtProjSimple what is the difference?
dbtColonnade = dbColonnade $ mconcat dbtColonnade = dbColonnade $ mconcat
[ colSchool $ resultAllQualification . _qualificationSchool [ colSchool $ resultAllQualification . _qualificationSchool
, sortable (Just "qshort") (i18nCell MsgQualificationShort) $ \(view resultAllQualification -> quali) -> , sortable (Just "qshort") (i18nCell MsgQualificationShort) $ \(view resultAllQualification -> quali) ->
let qsh = qualificationShorthand quali in let qsh = qualificationShorthand quali in
anchorCell (LmsR (qualificationSchool quali) qsh) $ toWgt qsh anchorCell (LmsR (qualificationSchool quali) qsh) $ toWgt qsh
, sortable (Just "qname") (i18nCell MsgQualificationName) $ \(view resultAllQualification -> quali) -> , sortable (Just "qname") (i18nCell MsgQualificationName) $ \(view resultAllQualification -> quali) ->
let qsh = qualificationShorthand quali let qsh = qualificationShorthand quali
qnm = qualificationName quali qnm = qualificationName quali
in anchorCell (LmsR (qualificationSchool quali) qsh) $ toWgt qnm in anchorCell (LmsR (qualificationSchool quali) qsh) $ toWgt qnm
, sortable Nothing (i18nCell MsgQualificationDescription) $ \(view resultAllQualification -> quali) -> , sortable Nothing (i18nCell MsgQualificationDescription) $ \(view resultAllQualification -> quali) ->
maybeCell (qualificationDescription quali) markupCellLargeModal maybeCell (qualificationDescription quali) markupCellLargeModal
, sortable Nothing (i18nCell MsgQualificationValidDuration & cellTooltip MsgTableDiffDaysTooltip) $ , sortable Nothing (i18nCell MsgQualificationValidDuration & cellTooltip MsgTableDiffDaysTooltip) $
foldMap (textCell . formatCalendarDiffDays . fromMonths) . view (resultAllQualification . _qualificationValidDuration) foldMap (textCell . formatCalendarDiffDays . fromMonths) . view (resultAllQualification . _qualificationValidDuration)
, sortable Nothing (i18nCell MsgQualificationRefreshWithin & cellTooltip MsgTableDiffDaysTooltip) $ , sortable Nothing (i18nCell MsgQualificationRefreshWithin & cellTooltip MsgTableDiffDaysTooltip) $
foldMap (textCell . formatCalendarDiffDays ) . view (resultAllQualification . _qualificationRefreshWithin) 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 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) , sortable (Just "qelearning") (i18nCell MsgTableLmsElearning & cellTooltip MsgQualificationElearningStart)
$ tickmarkCell . view (resultAllQualification . _qualificationElearningStart) $ tickmarkCell . view (resultAllQualification . _qualificationElearningStart)
, sortable Nothing (i18nCell MsgTableQualificationCountActive & cellTooltip MsgTableQualificationCountActiveTooltip) , sortable Nothing (i18nCell MsgTableQualificationCountActive & cellTooltip MsgTableQualificationCountActiveTooltip)
$ \(view resultAllQualificationActive -> n) -> wgtCell $ word2widget n $ \(view resultAllQualificationActive -> n) -> wgtCell $ word2widget n
, sortable Nothing (i18nCell MsgTableQualificationCountTotal) $ wgtCell . word2widget . view resultAllQualificationTotal , sortable Nothing (i18nCell MsgTableQualificationCountTotal) $ wgtCell . word2widget . view resultAllQualificationTotal
-- \(view resultAllQualificationTotal -> n) -> wgtCell $ word2widget n -- \(view resultAllQualificationTotal -> n) -> wgtCell $ word2widget n
] ]
dbtSorting = mconcat dbtSorting = mconcat
[ [
sortSchool $ to (E.^. QualificationSchool) sortSchool $ to (E.^. QualificationSchool)
@ -149,22 +149,8 @@ mkLmsAllTable = do
] ]
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
dbtParams = def dbtParams = def
{- = DBParamsForm
{ dbParamsFormMethod = POST
, dbParamsFormAction = Just $ SomeRoute currentRoute
, dbParamsFormAttrs = []
, dbParamsFormSubmit = FormSubmit
, dbParamsFormAdditional
= renderAForm FormStandard
$ (, mempty) . First . Just
<$> multiActionA acts (fslI MsgTableAction) Nothing
, dbParamsFormEvaluate = liftHandler . runFormPost
, dbParamsFormResult = id
, dbParamsFormIdent = def
}
-}
dbtIdent :: Text dbtIdent :: Text
dbtIdent = "qualification-overview" dbtIdent = "qualification-overview"
dbtCsvEncode = noCsvEncode dbtCsvEncode = noCsvEncode
dbtCsvDecode = Nothing dbtCsvDecode = Nothing
dbtExtraReps = [] dbtExtraReps = []
@ -176,7 +162,7 @@ mkLmsAllTable = do
getLmsEditR, postLmsEditR :: SchoolId -> QualificationShorthand -> Handler Html getLmsEditR, postLmsEditR :: SchoolId -> QualificationShorthand -> Handler Html
getLmsEditR = postLmsEditR getLmsEditR = postLmsEditR
postLmsEditR = error "TODO" postLmsEditR = error "TODO"
@ -204,18 +190,34 @@ resultUser = _dbrOutput . _2
resultLmsUser :: Traversal' LmsTableData (Entity LmsUser) resultLmsUser :: Traversal' LmsTableData (Entity LmsUser)
resultLmsUser = _dbrOutput . _3 . _Just resultLmsUser = _dbrOutput . _3 . _Just
instance HasEntity LmsTableData User where instance HasEntity LmsTableData User where
hasEntity = resultUser hasEntity = resultUser
instance HasUser LmsTableData where instance HasUser LmsTableData where
hasUser = resultUser . _entityVal hasUser = resultUser . _entityVal
mkLmsTable :: Entity Qualification -> DB (Any, Widget) data LmsTableAction = LmsActNotify
mkLmsTable (Entity qid quali) = do | LmsActRenewPin
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
instance Universe LmsTableAction
instance Finite LmsTableAction
nullaryPathPiece ''LmsTableAction $ camelToPathPiece' 2
embedRenderMessage ''UniWorX ''LmsTableAction id
-- Not yet needed, since there is no additional data for now:
data LmsTableActionData = LmsActNotifyData
| LmsActRenewPinData
deriving (Eq, Ord, Read, Show, Generic, Typeable)
mkLmsTable :: Entity Qualification -> DB (FormResult (LmsTableActionData, Set UserId), Widget)
mkLmsTable (Entity qid quali) = do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
currentRoute <- fromMaybe (error "mkLmsAllTable called from 404-handler") <$> liftHandler getCurrentRoute
let let
nowaday = utctDay now nowaday = utctDay now
mbRenewal = addGregorianDurationClip <$> qualificationRefreshWithin quali <*> Just nowaday mbRenewal = addGregorianDurationClip <$> qualificationRefreshWithin quali <*> Just nowaday
resultDBTable = DBTable{..} resultDBTable = DBTable{..}
where where
dbtSQLQuery = runReaderT $ do dbtSQLQuery = runReaderT $ do
@ -226,37 +228,37 @@ mkLmsTable (Entity qid quali) = do
E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser
E.on $ user E.^. UserId E.=?. lmsUser E.?. LmsUserUser E.on $ user E.^. UserId E.=?. lmsUser E.?. LmsUserUser
E.&&. E.val qid E.=?. lmsUser E.?. LmsUserQualification -- NOTE: condition was once erroneously placed in where-clause E.&&. E.val qid E.=?. lmsUser E.?. LmsUserQualification -- NOTE: condition was once erroneously placed in where-clause
E.where_ $ E.val qid E.==. qualUser E.^. QualificationUserQualification E.where_ $ E.val qid E.==. qualUser E.^. QualificationUserQualification
return (qualUser, user, lmsUser) return (qualUser, user, lmsUser)
dbtRowKey = queryUser >>> (E.^. UserId) dbtRowKey = queryUser >>> (E.^. UserId)
dbtProj = dbtProjFilteredPostId -- TODO: or dbtProjSimple what is the difference? dbtProj = dbtProjFilteredPostId -- TODO: or dbtProjSimple what is the difference?
dbtColonnade = dbColonnade $ mconcat dbtColonnade = dbColonnade $ mconcat
[ colUserNameLinkHdr MsgTableLmsUser AdminUserR [ colUserNameLinkHdr MsgTableLmsUser AdminUserR
, colUserEmail , colUserEmail
, sortable (Just "valid-until") (i18nCell MsgTableQualificationValidUntil) $ \( view $ resultQualUser . _entityVal . _qualificationUserValidUntil -> d) -> dayCell d , 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 "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 "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-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-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-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-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 , sortable (Just "lms-ended") (i18nLms MsgTableLmsEnded) $ \(preview $ resultLmsUser . _entityVal . _lmsUserEnded -> d) -> foldMap dateTimeCell $ join d
] ]
where where
i18nLms :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a i18nLms :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a
i18nLms msg = cell [whamlet|LMS #|] <> i18nCell msg i18nLms msg = cell [whamlet|LMS #|] <> i18nCell msg
dbtSorting = mconcat dbtSorting = mconcat
[ single $ sortUserNameLink queryUser [ single $ sortUserNameLink queryUser
, single $ sortUserEmail queryUser , single $ sortUserEmail queryUser
, single ("valid-until" , SortColumn $ queryQualUser >>> (E.^. QualificationUserValidUntil)) , single ("valid-until" , SortColumn $ queryQualUser >>> (E.^. QualificationUserValidUntil))
, single ("last-refresh", SortColumn $ queryQualUser >>> (E.^. QualificationUserLastRefresh)) , single ("last-refresh", SortColumn $ queryQualUser >>> (E.^. QualificationUserLastRefresh))
, single ("first-held" , SortColumn $ queryQualUser >>> (E.^. QualificationUserFirstHeld)) , single ("first-held" , SortColumn $ queryQualUser >>> (E.^. QualificationUserFirstHeld))
, single ("lms-ident" , SortColumn $ queryLmsUser >>> (E.?. LmsUserIdent)) , single ("lms-ident" , SortColumn $ queryLmsUser >>> (E.?. LmsUserIdent))
, single ("lms-status" , SortColumn $ views (to queryLmsUser) (E.?. LmsUserStatus)) , single ("lms-status" , SortColumn $ views (to queryLmsUser) (E.?. LmsUserStatus))
, single ("lms-started" , SortColumn $ queryLmsUser >>> (E.?. LmsUserStarted)) , single ("lms-started" , SortColumn $ queryLmsUser >>> (E.?. LmsUserStarted))
, single ("lms-received", SortColumn $ queryLmsUser >>> (E.?. LmsUserReceived)) , single ("lms-received", SortColumn $ queryLmsUser >>> (E.?. LmsUserReceived))
, single ("lms-ended" , SortColumn $ queryLmsUser >>> (E.?. LmsUserEnded)) , single ("lms-ended" , SortColumn $ queryLmsUser >>> (E.?. LmsUserEnded))
] ]
dbtFilter = mconcat dbtFilter = mconcat
[ single $ fltrUserNameEmail queryUser [ single $ fltrUserNameEmail queryUser
, single ("lms-ident" , FilterColumn . E.mkContainsFilterWith (Just . LmsIdent) $ views (to queryLmsUser) (E.?. LmsUserIdent)) , single ("lms-ident" , FilterColumn . E.mkContainsFilterWith (Just . LmsIdent) $ views (to queryLmsUser) (E.?. LmsUserIdent))
@ -268,32 +270,55 @@ mkLmsTable (Entity qid quali) = do
E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val nowaday E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val nowaday
| otherwise -> E.true | otherwise -> E.true
) )
] ]
dbtFilterUI mPrev = mconcat dbtFilterUI mPrev = mconcat
[ fltrUserNameEmailHdrUI MsgTableLmsUser mPrev [ fltrUserNameEmailHdrUI MsgTableLmsUser mPrev
, prismAForm (singletonFilter "lms-ident" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent) , 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 "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) , prismAForm (singletonFilter "validity" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsValid)
, if isNothing mbRenewal then mempty , if isNothing mbRenewal then mempty
else prismAForm (singletonFilter "renewal-due" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsRenewal) else prismAForm (singletonFilter "renewal-due" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsRenewal)
] ]
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
dbtParams = def
dbtIdent :: Text dbtIdent :: Text
dbtIdent = "qualification" dbtIdent = "qualification"
dbtCsvEncode = noCsvEncode dbtCsvEncode = noCsvEncode
dbtCsvDecode = Nothing dbtCsvDecode = Nothing
dbtExtraReps = [] dbtExtraReps = []
dbtParams = DBParamsForm
{ dbParamsFormMethod = POST
, dbParamsFormAction = Just $ SomeRoute currentRoute
, dbParamsFormAttrs = []
, dbParamsFormSubmit = FormSubmit
, dbParamsFormAdditional
= renderAForm FormStandard
$ (, mempty) . First . Just
<$> multiActionA acts (fslI MsgTableAction) Nothing
, dbParamsFormEvaluate = liftHandler . runFormPost
, dbParamsFormResult = id
, dbParamsFormIdent = def
}
acts :: Map LmsTableAction (AForm Handler LmsTableActionData)
acts = mconcat
[ singletonMap LmsActNotify $ pure LmsActNotifyData
, singletonMap LmsActRenewPin $ pure LmsActRenewPinData
]
postprocess :: FormResult (First LmsTableActionData, DBFormResult UserId Bool (DBRow (Entity User))) -> FormResult (LmsTableActionData, Set UserId)
postprocess inp = do
(First (Just act), usrMap) <- inp
let usrSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) usrMap
return (act, usrSet)
resultDBTableValidator = def resultDBTableValidator = def
-- & defaultSorting [SortAscBy csvLmsIdent] -- & defaultSorting [SortAscBy csvLmsIdent]
dbTable resultDBTableValidator resultDBTable over _1 postprocess <$> dbTable resultDBTableValidator resultDBTable
getLmsR, postLmsR :: SchoolId -> QualificationShorthand -> Handler Html getLmsR, postLmsR :: SchoolId -> QualificationShorthand -> Handler Html
getLmsR = postLmsR getLmsR = postLmsR
postLmsR sid qsh = do postLmsR sid qsh = do
(lmsTable, quali) <- runDB $ do (lmsTable, quali) <- runDB $ do
qent@(Entity _qid quali) <- getBy404 $ SchoolQualificationShort sid qsh qent@(Entity _qid quali) <- getBy404 $ SchoolQualificationShort sid qsh
tbl <- view _2 <$> mkLmsTable qent tbl <- view _2 <$> mkLmsTable qent
return (tbl, quali) return (tbl, quali)
let heading = citext2widget $ qualificationName quali let heading = citext2widget $ qualificationName quali