diff --git a/messages/uniworx/categories/qualification/de-de-formal.msg b/messages/uniworx/categories/qualification/de-de-formal.msg index ed3b858e5..5095dfef3 100644 --- a/messages/uniworx/categories/qualification/de-de-formal.msg +++ b/messages/uniworx/categories/qualification/de-de-formal.msg @@ -19,9 +19,14 @@ TableLmsPin: E-Lernen Pin TableLmsResetPin: Pin zurücksetzen? TableLmsDelete: Löschen? TableLmsStaff: Interner Mitarbeiter? -TableLmsReceived: Erhalten +TableLmsStarted: Begonnen +TableLmsReceived: Letzte Rückmeldung +TableLmsEnded: Beended +TableLmsStatus: Status E-Lernen TableLmsSuccess: Bestanden TableLmsFailed: Gesperrt +FilterLmsValid: Aktuell gültig +FilterLmsRenewal: Erneuerung anstehend CsvColumnLmsIdent: E-Lernen Identifikator, einzigartig pro Qualifikation und Teilnehmer CsvColumnLmsPin: PIN des E-Lernen Zugangs CsvColumnLmsResetPin: Wird die PIN bei der nächsten Synchronisation zurückgesetzt? diff --git a/messages/uniworx/categories/qualification/en-eu.msg b/messages/uniworx/categories/qualification/en-eu.msg index 978b29208..6347658a3 100644 --- a/messages/uniworx/categories/qualification/en-eu.msg +++ b/messages/uniworx/categories/qualification/en-eu.msg @@ -19,9 +19,14 @@ TableLmsElearning: E-learning TableLmsResetPin: Reset pin? TableLmsDelete: Delete? TableLmsStaff: Staff? -TableLmsReceived: Received +TableLmsStarted: Started +TableLmsReceived: Last received +TableLmsEnded: Ended +TableLmsStatus: Status e-learning TableLmsSuccess: Completed TableLmsFailed: Blocked +FilterLmsValid: Currently valid +FilterLmsRenewal: Renewal due CsvColumnLmsIdent: E-learning identifier, unique for each qualfication and user CsvColumnLmsPin: PIN for e-learning access CsvColumnLmsResetPin: Will the e-learning PIN be reset upon next synchronisation? diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index 92f29c96f..e9d18bbd9 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -19,7 +19,7 @@ import Import import Handler.Utils -- import Handler.Utils.Csv -import Handler.Utils.LMS +-- import Handler.Utils.LMS import qualified Data.Map as Map -- import qualified Data.Csv as Csv @@ -166,9 +166,12 @@ instance HasEntity LmsTableData User where instance HasUser LmsTableData where hasUser = resultUser . _entityVal -mkLmsTable :: QualificationId -> DB (Any, Widget) -mkLmsTable qid = do +mkLmsTable :: Entity Qualification -> DB (Any, Widget) +mkLmsTable (Entity qid quali) = do + now <- liftIO getCurrentTime let + nowaday = utctDay now + mbRenewal = addGregorianDurationClip <$> qualificationRefreshWithin quali <*> Just nowaday resultDBTable = DBTable{..} where dbtSQLQuery = runReaderT $ do @@ -190,21 +193,34 @@ mkLmsTable qid = do , 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 csvLmsIdent) (i18nCell MsgTableLmsIdent) $ \(preview $ resultLmsUser . _entityVal . _lmsUserIdent . _getLmsIdent -> lid) -> foldMap textCell lid - , sortable (Just csvLmsSuccess) (i18nCell MsgTableLmsSuccess) $ \(preview $ resultLmsUser . _entityVal . _lmsUserStatus -> status) -> foldMap lmsStatusCell $ join status - ] -- TODO: add more columns for manual debugging view !!! + , 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 [ 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 (csvLmsIdent , SortColumn $ queryLmsUser >>> (E.?. LmsResultIdent)) - -- , (csvLmsSuccess, SortColumn $ queryLmsResult >>> (E.^. LmsResultSuccess)) - -- , (csvLmsSuccess, SortColumn $ views (to queryLmsResult) (E.^. LmsResultSuccess)) + , 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 ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) ((E.>=. E.val nowaday) . (E.^. QualificationUserValidUntil))) + , maybe mempty (\renewal -> + single ("renewal-due" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) ((E.<=. E.val renewal) . E.just . (E.^. QualificationUserValidUntil)))) + mbRenewal -- , single $ fltrUserNameEmail queryUser --("user" , FilterColumn . E.mkContainsFilterWith Just $ views (to queryUser) (E.^. UserDisplayName)) -- , ("email" , FilterColumn . E.mkContainsFilterWith Just $ views (to queryUser) (E.^. UserEmail)) @@ -213,10 +229,13 @@ mkLmsTable qid = do ] dbtFilterUI mPrev = mconcat [ fltrUserNameEmailHdrUI MsgTableLmsUser mPrev + , prismAForm (singletonFilter "lms-ident" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent) + , 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) -- , fltrUserNameEmailUI mPrev -- prismAForm (singletonFilter "user" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsUser) --, prismAForm (singletonFilter "email" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableEmail) - -- , prismAForm (singletonFilter csvLmsIdent . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent) -- , prismAForm (singletonFilter csvLmsSuccess . maybePrism _PathPiece) mPrev $ aopt (hoistField lift checkBoxField) (fslI MsgTableLmsSuccess) ] dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } @@ -228,15 +247,15 @@ mkLmsTable qid = do dbtExtraReps = [] resultDBTableValidator = def - & defaultSorting [SortAscBy csvLmsIdent] + -- & defaultSorting [SortAscBy csvLmsIdent] dbTable resultDBTableValidator resultDBTable getLmsR, postLmsR :: SchoolId -> QualificationShorthand -> Handler Html getLmsR = postLmsR postLmsR sid qsh = do (lmsTable, quali) <- runDB $ do - Entity qid quali <- getBy404 $ SchoolQualificationShort sid qsh - tbl <- view _2 <$> mkLmsTable qid + qent@(Entity _qid quali) <- getBy404 $ SchoolQualificationShort sid qsh + tbl <- view _2 <$> mkLmsTable qent return (tbl, quali) let heading = citext2widget $ qualificationName quali siteLayout heading $ do diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index 15e26c06d..1c02c7e98 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -299,7 +299,7 @@ cryptoidCell :: (IsDBTable m a, PathPiece cid) => cid -> DBCell m a cryptoidCell = addCellClass ("cryptoid" :: Text) . textCell . toPathPiece lmsStatusCell :: IsDBTable m a => LmsStatus -> DBCell m a -lmsStatusCell ls = iconCell ic <> dayCell (lmsStatusDay ls) +lmsStatusCell ls = iconCell ic <> spacerCell <> dayCell (lmsStatusDay ls) where ic | isLmsSuccess ls = IconOK | otherwise = IconNotOK \ No newline at end of file diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index c1c0c4f38..72ba41944 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -468,6 +468,7 @@ fillDb = do void . insert' $ QualificationUser gkleen qid_f (n_day $ -3) (n_day $ -4) (n_day $ -20) void . insert' $ QualificationUser maxMuster qid_f (n_day 0) (n_day $ -2) (n_day $ -8) void . insert' $ QualificationUser svaupel qid_f (n_day 1) (n_day $ -1) (n_day $ -2) + void . insert' $ QualificationUser sbarth qid_f (n_day 400) (n_day $ -40) (n_day $ -1200) void . insert' $ QualificationUser gkleen qid_r (n_day $ -7) (n_day $ -2) (n_day $ -9) void . insert' $ QualificationUser maxMuster qid_r (n_day 1) (n_day $ -1) (n_day $ -2) void . insert' $ QualificationUser fhamann qid_r (n_day $ -3) (n_day $ -1) (n_day $ -2)