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

176
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,41 +198,66 @@ 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
now <- liftIO getCurrentTime | LmsActRenewPin
let deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
nowaday = utctDay now
mbRenewal = addGregorianDurationClip <$> qualificationRefreshWithin quali <*> Just nowaday instance Universe LmsTableAction
resultDBTable = DBTable{..} instance Finite LmsTableAction
where nullaryPathPiece ''LmsTableAction $ camelToPathPiece' 2
dbtSQLQuery = runReaderT $ do embedRenderMessage ''UniWorX ''LmsTableAction id
qualUser <- asks queryQualUser
user <- asks queryUser -- Not yet needed, since there is no additional data for now:
lmsUser <- asks queryLmsUser data LmsTableActionData = LmsActNotifyData
lift $ do | 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.==. 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)
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
dbtSQLQuery q = lmsTableQuery qid q <* E.where_ (restrict q)
dbtRowKey = queryUser >>> (E.^. UserId) dbtRowKey = queryUser >>> (E.^. UserId)
dbtProj = dbtProjFilteredPostId -- TODO: or dbtProjSimple what is the difference? dbtProj = dbtProjFilteredPostId
dbtColonnade = dbColonnade $ mconcat dbtColonnade = cols
[ 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-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 dbtSorting = mconcat
[ single $ sortUserNameLink queryUser [ single $ sortUserNameLink queryUser
, single $ sortUserEmail queryUser , single $ sortUserEmail queryUser
@ -278,24 +291,85 @@ mkLmsTable (Entity qid quali) = do
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
}
resultDBTableValidator = 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] -- & defaultSorting [SortAscBy csvLmsIdent]
dbTable resultDBTableValidator resultDBTable over _1 postprocess <$> dbTable psValidator DBTable{..}
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 ((lmsRes, lmsTable), Entity qid quali) <- runDB $ do
qent@(Entity _qid quali) <- getBy404 $ SchoolQualificationShort sid qsh qent <- getBy404 $ SchoolQualificationShort sid qsh
tbl <- view _2 <$> mkLmsTable qent let acts :: Map LmsTableAction (AForm Handler LmsTableActionData)
return (tbl, quali) 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-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
psValidator = def
tbl <- mkLmsTable qent acts (const E.true) colChoices psValidator
return (tbl, qent)
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 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