Merge branch csv osis demo into master
This commit is contained in:
Steffen Jost
Sarah Vaupel
parent
9d4904f759
commit
20be959aff
@ -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.
|
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
|
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-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"}.
|
||||||
@ -45,3 +45,8 @@ LmsErrorNoRefreshElearning: Error: E-learning will not be started automatically
|
|||||||
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: 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"}.
|
||||||
@ -101,7 +101,8 @@ LmsUser
|
|||||||
received UTCTime Maybe -- last acknowledgement by LMS
|
received UTCTime Maybe -- last acknowledgement by LMS
|
||||||
ended UTCTime Maybe -- ident was deleted from LMS
|
ended UTCTime Maybe -- ident was deleted from LMS
|
||||||
-- Primary ident -- newtype Key LmsUserId = LmsUserKey { unLmsUser :: Text } -- change LmsIdent -> Text. Do we want this?
|
-- 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
|
deriving Generic
|
||||||
|
|
||||||
-- LmsUserlist stores LMS upload for later processing only
|
-- LmsUserlist stores LMS upload for later processing only
|
||||||
|
|||||||
@ -20,8 +20,10 @@ import Import
|
|||||||
import Jobs
|
import Jobs
|
||||||
import Handler.Utils
|
import Handler.Utils
|
||||||
-- import Handler.Utils.Csv
|
-- 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.Map as Map
|
||||||
-- import qualified Data.Csv as Csv
|
-- import qualified Data.Csv as Csv
|
||||||
-- import qualified Data.Conduit.List as C
|
-- import qualified Data.Conduit.List as C
|
||||||
@ -149,20 +151,6 @@ 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
|
||||||
@ -210,28 +198,149 @@ instance HasEntity LmsTableData User where
|
|||||||
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
|
| 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
|
now <- liftIO getCurrentTime
|
||||||
|
-- currentRoute <- fromMaybe (error "mkLmsAllTable called from 404-handler") <$> liftHandler getCurrentRoute -- we know the route precisely heres
|
||||||
let
|
let
|
||||||
|
currentRoute = LmsR (qualificationSchool quali) (qualificationShorthand quali)
|
||||||
nowaday = utctDay now
|
nowaday = utctDay now
|
||||||
mbRenewal = addGregorianDurationClip <$> qualificationRefreshWithin quali <*> Just nowaday
|
mbRenewal = addGregorianDurationClip <$> qualificationRefreshWithin quali <*> Just nowaday
|
||||||
resultDBTable = DBTable{..}
|
dbtSQLQuery q = lmsTableQuery qid q <* E.where_ (restrict q)
|
||||||
where
|
dbtRowKey = queryUser >>> (E.^. UserId)
|
||||||
dbtSQLQuery = runReaderT $ do
|
dbtProj = dbtProjFilteredPostId
|
||||||
qualUser <- asks queryQualUser
|
dbtColonnade = cols
|
||||||
user <- asks queryUser
|
dbtSorting = mconcat
|
||||||
lmsUser <- asks queryLmsUser
|
[ single $ sortUserNameLink queryUser
|
||||||
lift $ do
|
, single $ sortUserEmail queryUser
|
||||||
E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser
|
, single ("valid-until" , SortColumn $ queryQualUser >>> (E.^. QualificationUserValidUntil))
|
||||||
E.on $ user E.^. UserId E.=?. lmsUser E.?. LmsUserUser
|
, single ("last-refresh", SortColumn $ queryQualUser >>> (E.^. QualificationUserLastRefresh))
|
||||||
E.&&. E.val qid E.=?. lmsUser E.?. LmsUserQualification -- NOTE: condition was once erroneously placed in where-clause
|
, single ("first-held" , SortColumn $ queryQualUser >>> (E.^. QualificationUserFirstHeld))
|
||||||
E.where_ $ E.val qid E.==. qualUser E.^. QualificationUserQualification
|
, single ("lms-ident" , SortColumn $ queryLmsUser >>> (E.?. LmsUserIdent))
|
||||||
return (qualUser, user, lmsUser)
|
, single ("lms-status" , SortColumn $ views (to queryLmsUser) (E.?. LmsUserStatus))
|
||||||
dbtRowKey = queryUser >>> (E.^. UserId)
|
, single ("lms-started" , SortColumn $ queryLmsUser >>> (E.?. LmsUserStarted))
|
||||||
dbtProj = dbtProjFilteredPostId -- TODO: or dbtProjSimple what is the difference?
|
, single ("lms-received", SortColumn $ queryLmsUser >>> (E.?. LmsUserReceived))
|
||||||
dbtColonnade = dbColonnade $ mconcat
|
, single ("lms-ended" , SortColumn $ queryLmsUser >>> (E.?. LmsUserEnded))
|
||||||
[ colUserNameLinkHdr MsgTableLmsUser AdminUserR
|
]
|
||||||
|
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
|
, 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
|
||||||
@ -243,59 +352,24 @@ mkLmsTable (Entity qid quali) = do
|
|||||||
, 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
|
psValidator = def
|
||||||
[ single $ sortUserNameLink queryUser
|
tbl <- mkLmsTable qent acts (const E.true) colChoices psValidator
|
||||||
, single $ sortUserEmail queryUser
|
return (tbl, qent)
|
||||||
, 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
|
formResult lmsRes $ \case
|
||||||
-- & defaultSorting [SortAscBy csvLmsIdent]
|
(action, selectedUsers) -> do -- | isRenewPinAct action || isNotifyAct action -> do
|
||||||
dbTable resultDBTableValidator resultDBTable
|
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
|
||||||
|
|
||||||
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)
|
|
||||||
let heading = citext2widget $ qualificationName quali
|
let heading = citext2widget $ qualificationName quali
|
||||||
siteLayout heading $ do
|
siteLayout heading $ do
|
||||||
setTitle $ toHtml $ unSchoolKey sid <> "-" <> qsh
|
setTitle $ toHtml $ unSchoolKey sid <> "-" <> qsh
|
||||||
|
|||||||
@ -268,7 +268,7 @@ postLmsResultDirectR sid qsh = do
|
|||||||
.| decodeCsv
|
.| decodeCsv
|
||||||
.| foldMC (saveResultCsv qid) 0
|
.| foldMC (saveResultCsv qid) 0
|
||||||
case enr of
|
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
|
$logWarnS "LMS" $ "Result upload failed parsing: " <> tshow e
|
||||||
return (badRequest400, "Exception: " <> tshow e)
|
return (badRequest400, "Exception: " <> tshow e)
|
||||||
Right nr -> do
|
Right nr -> do
|
||||||
|
|||||||
Reference in New Issue
Block a user