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

Merge branch 'csv-osis-demo' into 'master'

Browse Source 
Merge branch csv osis demo into master

See merge request FraDrive/fradrive!9
This commit is contained in:
Sarah Vaupel 2022-06-03 20:08:08 +02:00
commit 47fd77838e
5 changed files with 208 additions and 123 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -44,4 +44,9 @@ 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.
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.
MailLmsRenewalBody: Sie müssen diese Qualifikaton demnächst durch einen E-Lernen Kurs erneuern.
LmsActNotify: Benachrichtigung E-Lernen erneut per Post oder E-Mail versenden
LmsActRenewPin: Neue zufällige E-Lernen PIN zuweisen
LmsActRenewNotify: Neue zufällige E-Lernen PIN zuweisen und Benachrichtigung per Post oder E-Mail versenden
LmsNotificationSend n@Int: E-Lernen Benachrichtigungen an #{n} #{pluralDE n "Prüfling" "Prüflinge"} werden per Post oder E-Mail versendet.
LmsPinRenewal n@Int: E-Lernen Pin ausgetauscht für #{n} #{pluralDE n "Prüfling" "Prüflinge"}.

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

@ -44,4 +44,9 @@ 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: Resend e-learning notification by post or email
LmsActRenewPin: Randomly replace e-learning PIN
LmsActRenewNotify: Randomly replace e-learning PIN and re-send notification by post or email
LmsNotificationSend n@Int: E-learning notifications will be sent to #{n} #{pluralEN n "Examinee" "Examinees"} by letter post or by email.
LmsPinRenewal n@Int: E-learning pin replaced randomly for #{n} #{pluralEN n "Examinee" "Examinees"}.

3
models/lms.model
View File

@ -101,7 +101,8 @@ LmsUser
received UTCTime Maybe -- last acknowledgement by LMS
ended UTCTime Maybe -- ident was deleted from LMS
-- Primary ident -- newtype Key LmsUserId = LmsUserKey { unLmsUser :: Text } -- change LmsIdent -> Text. Do we want this?
UniqueLmsUser ident -- idents must be unique accross all qualifications, since idents are global within LMS!
UniqueLmsIdent ident -- idents must be unique accross all qualifications, since idents are global within LMS!
UniqueLmsQualificationUser qualification user -- each user may be enrolled at most once per course
deriving Generic
-- LmsUserlist stores LMS upload for later processing only

312
src/Handler/LMS.hs
View File

@ -20,8 +20,10 @@ import Import
import Jobs
import Handler.Utils
-- import Handler.Utils.Csv
-- import Handler.Utils.LMS
import Handler.Utils.LMS
import qualified Data.Set as Set
import qualified Data.Map as Map
-- import qualified Data.Csv as Csv
-- import qualified Data.Conduit.List as C
@ -38,21 +40,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 +63,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 +92,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 +151,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 +164,7 @@ mkLmsAllTable = do
getLmsEditR, postLmsEditR :: SchoolId -> QualificationShorthand -> Handler Html
getLmsEditR = postLmsEditR
getLmsEditR = postLmsEditR
postLmsEditR = error "TODO"
@ -204,98 +192,184 @@ 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
| LmsActRenewNotify
| 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
| LmsActRenewNotifyData
| LmsActRenewPinData
deriving (Eq, Ord, Read, Show, Generic, Typeable)
isNotifyAct :: LmsTableActionData -> Bool
isNotifyAct LmsActNotifyData = True
isNotifyAct LmsActRenewNotifyData = True
isNotifyAct LmsActRenewPinData = False
isRenewPinAct :: LmsTableActionData -> Bool
isRenewPinAct LmsActNotifyData = False
isRenewPinAct LmsActRenewNotifyData = True
isRenewPinAct LmsActRenewPinData = True
lmsTableQuery :: QualificationId -> LmsTableExpr -> E.SqlQuery ( E.SqlExpr (Entity QualificationUser)
, E.SqlExpr (Entity User)
, E.SqlExpr (Maybe (Entity LmsUser))
)
lmsTableQuery qid (qualUser `E.InnerJoin` user `E.LeftOuterJoin` lmsUser) = 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
return (qualUser, user, lmsUser)
mkLmsTable :: forall h p cols act act'.
( Functor h, ToSortable h
, Ord act, PathPiece act, RenderMessage UniWorX act
, AsCornice h p LmsTableData (DBCell (MForm Handler) (FormResult (First act', DBFormResult UserId Bool LmsTableData))) cols
)
=> Entity Qualification
-> Map act (AForm Handler act')
-> (LmsTableExpr -> E.SqlExpr (E.Value Bool))
-> cols
-> PSValidator (MForm Handler) (FormResult (First act', DBFormResult UserId Bool LmsTableData))
-> DB (FormResult (act', Set UserId), Widget)
mkLmsTable (Entity qid quali) acts restrict cols psValidator = do
now <- liftIO getCurrentTime
-- currentRoute <- fromMaybe (error "mkLmsAllTable called from 404-handler") <$> liftHandler getCurrentRoute -- we know the route precisely heres
let
currentRoute = LmsR (qualificationSchool quali) (qualificationShorthand quali)
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 -- NOTE: condition was once erroneously placed in where-clause
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
mbRenewal = addGregorianDurationClip <$> qualificationRefreshWithin quali <*> Just nowaday
dbtSQLQuery q = lmsTableQuery qid q <* E.where_ (restrict q)
dbtRowKey = queryUser >>> (E.^. UserId)
dbtProj = dbtProjFilteredPostId
dbtColonnade = cols
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 }
dbtIdent :: Text
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 act', DBFormResult UserId Bool LmsTableData)
-> FormResult ( act', 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 :: PSValidator (MForm Handler) (FormResult (First LmsTableActionData, DBFormResult UserId Bool LmsTableActionData))
-- resultDBTableValidator = def
-- & defaultSorting [SortAscBy csvLmsIdent]
over _1 postprocess <$> dbTable psValidator DBTable{..}
getLmsR, postLmsR :: SchoolId -> QualificationShorthand -> Handler Html
getLmsR = postLmsR
postLmsR sid qsh = do
((lmsRes, lmsTable), Entity qid quali) <- runDB $ do
qent <- getBy404 $ SchoolQualificationShort sid qsh
let acts :: Map LmsTableAction (AForm Handler LmsTableActionData)
acts = mconcat
[ singletonMap LmsActNotify $ pure LmsActNotifyData
, singletonMap LmsActRenewNotify $ pure LmsActRenewNotifyData
, singletonMap LmsActRenewPin $ pure LmsActRenewPinData
]
colChoices = mconcat
[ dbSelect (applying _2) id (return . view (resultUser . _entityKey))
, 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-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 = []
where
-- i18nLms :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a
i18nLms msg = cell [whamlet|LMS #|] <> i18nCell msg
psValidator = def
tbl <- mkLmsTable qent acts (const E.true) colChoices psValidator
return (tbl, qent)
resultDBTableValidator = def
-- & defaultSorting [SortAscBy csvLmsIdent]
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
tbl <- view _2 <$> mkLmsTable qent
return (tbl, quali)
formResult lmsRes $ \case
(action, selectedUsers) -> do -- | isRenewPinAct action || isNotifyAct action -> do
runDBJobs $ forM_ selectedUsers $ \uid -> do
when (isRenewPinAct action) $ do
newPin <- liftIO randomLMSpw
updateBy (UniqueLmsQualificationUser qid uid) [LmsUserPin =. newPin] -- must be within its own runDB
when (isNotifyAct action) $
queueDBJob $ JobSendNotification { jRecipient = uid, jNotification = NotificationQualificationRenewal qid}
let numExaminees = Set.size selectedUsers
when (isRenewPinAct action) $ addMessageI Success $ MsgLmsPinRenewal numExaminees
when (isNotifyAct action) $ addMessageI Success $ MsgLmsNotificationSend numExaminees
let heading = citext2widget $ qualificationName quali
siteLayout heading $ do
setTitle $ toHtml $ unSchoolKey sid <> "-" <> qsh

2
src/Handler/LMS/Result.hs
View File

@ -268,7 +268,7 @@ postLmsResultDirectR sid qsh = do
.| decodeCsv
.| foldMC (saveResultCsv qid) 0
case enr of
Left (e :: SomeException) -> do
Left (e :: SomeException) -> do -- catch all to avoid ok220 in case of any error
$logWarnS "LMS" $ "Result upload failed parsing: " <> tshow e
return (badRequest400, "Exception: " <> tshow e)
Right nr -> do