chore(lms): wip actions for lms table
This commit is contained in:
Steffen Jost
parent
9d4904f759
commit
549a9b5d9b
@ -45,3 +45,5 @@ LmsErrorNoRefreshElearning: Fehler: E-Lernen wird nicht automatisch gestartet, d
|
||||
MailSubjectQualificationRenewal qname@Text: Ihre Qualifikation #{qname} muss demnächst erneuert werden
|
||||
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.
|
||||
LmsActNotify: Benachrichtigung E-Lernen erneut versenden
|
||||
LmsActRenewPin: Neue zufällig E-Lernen PIN setzen
|
||||
@ -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.
|
||||
MailSubjectQualificationRenewal qname@Text: Your qualification #{qname} must be renewed shortly
|
||||
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
|
||||
@ -38,21 +38,21 @@ import Handler.LMS.Result as Handler.LMS
|
||||
single :: (k,a) -> Map k a
|
||||
single = uncurry Map.singleton
|
||||
|
||||
-- Button only needed here
|
||||
-- Button only needed here
|
||||
data ButtonManualLms = LmsEnqueue | LmsDequeue
|
||||
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
|
||||
instance Universe ButtonManualLms
|
||||
instance Universe ButtonManualLms
|
||||
instance Finite ButtonManualLms
|
||||
|
||||
nullaryPathPiece ''ButtonManualLms camelToPathPiece
|
||||
|
||||
instance Button UniWorX ButtonManualLms where
|
||||
btnLabel LmsEnqueue = "Enqeue"
|
||||
btnLabel LmsDequeue = "Deqeue"
|
||||
btnLabel LmsDequeue = "Deqeue"
|
||||
|
||||
btnClasses LmsEnqueue = [BCIsButton, BCPrimary]
|
||||
btnClasses LmsDequeue = [BCIsButton, BCDefault]
|
||||
|
||||
|
||||
|
||||
getLmsSchoolR :: SchoolId -> Handler Html
|
||||
getLmsSchoolR ssh = redirect (LmsAllR, [("qualification-overview-school", toPathPiece ssh)])
|
||||
@ -61,26 +61,26 @@ getLmsAllR, postLmsAllR :: Handler Html
|
||||
getLmsAllR = postLmsAllR
|
||||
postLmsAllR = do
|
||||
((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm ("buttons" :: Text) (buttonForm :: Form ButtonManualLms)
|
||||
let btnForm = wrapForm btnWdgt def
|
||||
let btnForm = wrapForm btnWdgt def
|
||||
{ formAction = Just $ SomeRoute LmsAllR
|
||||
, formEncoding = btnEnctype
|
||||
, formSubmit = FormNoSubmit
|
||||
}
|
||||
case btnResult of
|
||||
case btnResult of
|
||||
(FormSuccess LmsEnqueue) -> queueJob' JobLmsQualificationsEnqueue
|
||||
(FormSuccess LmsDequeue) -> queueJob' JobLmsQualificationsDequeue
|
||||
FormMissing -> return ()
|
||||
_other -> addMessage Warning "Kein korrekter LMS Knopf erkannt"
|
||||
|
||||
lmsTable <- runDB $ do
|
||||
view _2 <$> mkLmsAllTable
|
||||
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
|
||||
resultAllQualification = _dbrOutput . _1 . _entityVal
|
||||
|
||||
resultAllQualificationActive :: Lens' AllQualificationTableData Word64
|
||||
resultAllQualificationActive = _dbrOutput . _2 . _unValue
|
||||
@ -90,46 +90,46 @@ resultAllQualificationTotal = _dbrOutput . _3 . _unValue
|
||||
|
||||
|
||||
mkLmsAllTable :: DB (Any, Widget)
|
||||
mkLmsAllTable = do
|
||||
mkLmsAllTable = do
|
||||
now <- liftIO getCurrentTime
|
||||
let
|
||||
let
|
||||
resultDBTable = DBTable{..}
|
||||
where
|
||||
dbtSQLQuery quali = do
|
||||
cusers <- pure . Ex.subSelectCount $ do
|
||||
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
|
||||
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
|
||||
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)
|
||||
-- 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
|
||||
, 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) ->
|
||||
, sortable (Just "qname") (i18nCell MsgQualificationName) $ \(view resultAllQualification -> quali) ->
|
||||
let qsh = qualificationShorthand quali
|
||||
qnm = qualificationName 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) $
|
||||
, 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)
|
||||
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)
|
||||
, sortable (Just "qelearning") (i18nCell MsgTableLmsElearning & cellTooltip MsgQualificationElearningStart)
|
||||
$ tickmarkCell . view (resultAllQualification . _qualificationElearningStart)
|
||||
, sortable Nothing (i18nCell MsgTableQualificationCountActive & cellTooltip MsgTableQualificationCountActiveTooltip)
|
||||
, 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)
|
||||
@ -149,22 +149,8 @@ mkLmsAllTable = do
|
||||
]
|
||||
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
|
||||
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 = "qualification-overview"
|
||||
dbtIdent = "qualification-overview"
|
||||
dbtCsvEncode = noCsvEncode
|
||||
dbtCsvDecode = Nothing
|
||||
dbtExtraReps = []
|
||||
@ -176,7 +162,7 @@ mkLmsAllTable = do
|
||||
|
||||
|
||||
getLmsEditR, postLmsEditR :: SchoolId -> QualificationShorthand -> Handler Html
|
||||
getLmsEditR = postLmsEditR
|
||||
getLmsEditR = postLmsEditR
|
||||
postLmsEditR = error "TODO"
|
||||
|
||||
|
||||
@ -204,18 +190,34 @@ resultUser = _dbrOutput . _2
|
||||
resultLmsUser :: Traversal' LmsTableData (Entity LmsUser)
|
||||
resultLmsUser = _dbrOutput . _3 . _Just
|
||||
|
||||
instance HasEntity LmsTableData User where
|
||||
hasEntity = resultUser
|
||||
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
|
||||
data LmsTableAction = LmsActNotify
|
||||
| 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
|
||||
currentRoute <- fromMaybe (error "mkLmsAllTable called from 404-handler") <$> liftHandler getCurrentRoute
|
||||
let
|
||||
nowaday = utctDay now
|
||||
mbRenewal = addGregorianDurationClip <$> qualificationRefreshWithin quali <*> Just nowaday
|
||||
mbRenewal = addGregorianDurationClip <$> qualificationRefreshWithin quali <*> Just nowaday
|
||||
resultDBTable = DBTable{..}
|
||||
where
|
||||
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.=?. lmsUser E.?. LmsUserUser
|
||||
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)
|
||||
dbtRowKey = queryUser >>> (E.^. UserId)
|
||||
dbtProj = dbtProjFilteredPostId -- TODO: or dbtProjSimple what is the difference?
|
||||
dbtColonnade = dbColonnade $ mconcat
|
||||
[ colUserNameLinkHdr MsgTableLmsUser AdminUserR
|
||||
, colUserEmail
|
||||
, 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-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
|
||||
]
|
||||
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 $ sortUserEmail queryUser
|
||||
, single ("valid-until" , SortColumn $ queryQualUser >>> (E.^. QualificationUserValidUntil))
|
||||
, single ("last-refresh", SortColumn $ queryQualUser >>> (E.^. QualificationUserLastRefresh))
|
||||
, single ("first-held" , SortColumn $ queryQualUser >>> (E.^. QualificationUserFirstHeld))
|
||||
, single ("first-held" , SortColumn $ queryQualUser >>> (E.^. QualificationUserFirstHeld))
|
||||
, single ("lms-ident" , SortColumn $ queryLmsUser >>> (E.?. LmsUserIdent))
|
||||
, single ("lms-status" , SortColumn $ views (to queryLmsUser) (E.?. LmsUserStatus))
|
||||
, single ("lms-started" , SortColumn $ queryLmsUser >>> (E.?. LmsUserStarted))
|
||||
, 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))
|
||||
@ -268,32 +270,55 @@ mkLmsTable (Entity qid quali) = do
|
||||
E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val nowaday
|
||||
| otherwise -> E.true
|
||||
)
|
||||
]
|
||||
dbtFilterUI mPrev = mconcat
|
||||
]
|
||||
dbtFilterUI mPrev = mconcat
|
||||
[ 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 "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"
|
||||
dbtIdent = "qualification"
|
||||
dbtCsvEncode = noCsvEncode
|
||||
dbtCsvDecode = Nothing
|
||||
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
|
||||
-- & defaultSorting [SortAscBy csvLmsIdent]
|
||||
dbTable resultDBTableValidator resultDBTable
|
||||
over _1 postprocess <$> dbTable resultDBTableValidator resultDBTable
|
||||
|
||||
getLmsR, postLmsR :: SchoolId -> QualificationShorthand -> Handler Html
|
||||
getLmsR = postLmsR
|
||||
postLmsR sid qsh = do
|
||||
(lmsTable, quali) <- runDB $ do
|
||||
qent@(Entity _qid quali) <- getBy404 $ SchoolQualificationShort sid qsh
|
||||
(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
|
||||
|
||||
Reference in New Issue
Block a user