fraport/fradrive-old
Archived
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. 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"}.

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

@ -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"}.

3
models/lms.model
View File

@ -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

240
src/Handler/LMS.hs
View File

@ -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

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

@ -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