diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index 9e3754e22..5bd55d275 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -36,7 +36,7 @@ import qualified Data.CaseInsensitive as CI import qualified Data.Conduit.List as C import qualified Database.Esqueleto.Experimental as Ex -- needs TypeApplications Lang-Pragma import qualified Database.Esqueleto.Legacy as E -import qualified Database.Esqueleto.PostgreSQL as E +-- import qualified Database.Esqueleto.PostgreSQL as E import qualified Database.Esqueleto.Utils as E import Database.Esqueleto.Utils.TH @@ -181,7 +181,7 @@ mkLmsAllTable isAdmin = do dbtCsvDecode = Nothing dbtExtraReps = [] - resultDBTableValidator = def + resultDBTableValidator = def & defaultSorting [SortAscBy "school", SortAscBy "qshort"] dbTable resultDBTableValidator resultDBTable @@ -341,12 +341,13 @@ lmsTableQuery qid (qualUser `E.InnerJoin` user `E.LeftOuterJoin` lmsUser) = do E.where_ $ E.val qid E.==. qualUser E.^. QualificationUserQualification -- TODO: decide whether to use subSelect or LeftOuterJoin and delete the other! -- Letztes Datum anzeigen, wenn mehrere, dann diese in klickbaren Tooltip verstecken! - let printAcknowledged = E.subSelectMaybe . E.from $ \pj -> do - E.where_ $ E.isJust (pj E.^. PrintJobLmsUser) - E.&&. ((lmsUser E.?. LmsUserIdent) E.==. (pj E.^. PrintJobLmsUser)) - let pjOrder = [E.desc $ pj E.^. PrintJobCreated, E.desc $ pj E.^. PrintJobAcknowledged] -- latest created comes first! This is assumed to be the case later on! - pure $ --(E.arrayAggWith E.AggModeAll (pj E.^. PrintJobCreated ) pjOrder, -- return two aggregates only works with select, the restricted typr of subSelect does not seem to support this! - E.arrayAggWith E.AggModeAll (pj E.^. PrintJobAcknowledged) pjOrder + -- let printAcknowledged = E.subSelectMaybe . E.from $ \pj -> do + -- E.where_ $ E.isJust (pj E.^. PrintJobLmsUser) + -- E.&&. ((lmsUser E.?. LmsUserIdent) E.==. (pj E.^. PrintJobLmsUser)) + -- let pjOrder = [E.desc $ pj E.^. PrintJobCreated, E.desc $ pj E.^. PrintJobAcknowledged] -- latest created comes first! This is assumed to be the case later on! + -- pure $ --(E.arrayAggWith E.AggModeAll (pj E.^. PrintJobCreated ) pjOrder, -- return two aggregates only works with select, the restricted typr of subSelect does not seem to support this! + -- E.arrayAggWith E.AggModeAll (pj E.^. PrintJobAcknowledged) pjOrder + let printAcknowledged = E.val Nothing return (qualUser, user, lmsUser, printAcknowledged) @@ -376,66 +377,66 @@ mkLmsTable isAdmin (Entity qid quali) acts restrict cols psValidator = do let currentRoute = LmsR (qualificationSchool quali) (qualificationShorthand quali) nowaday = utctDay now - mbRenewal = addGregorianDurationClip <$> qualificationRefreshWithin quali <*> Just nowaday + _mbRenewal = addGregorianDurationClip <$> qualificationRefreshWithin quali <*> Just nowaday csvName = T.replace " " "-" $ CI.original (quali ^. _qualificationName) dbtIdent :: Text dbtIdent = "qualification" dbtSQLQuery q = lmsTableQuery qid q <* E.where_ (restrict q) dbtRowKey = queryUser >>> (E.^. UserId) - --dbtProj = dbtProjFilteredPostId - dbtProj = (views _dbtProjRow . set _dbrOutput) =<< do - qusr <- view $ _dbtProjRow . resultQualUser - user <- view $ _dbtProjRow . resultUser - lusr <- preview $ _dbtProjRow . resultLmsUser - pjac <- preview $ _dbtProjRow . resultPrintAck - forMM_ (view $ _dbtProjFilter . _ltProjFilterMayAccess) $ \b -> do - euid <- encrypt $ user ^. _entityKey - guardM . lift . lift . fmap (== b) . hasReadAccessTo . urlRoute $ ForProfileDataR euid -- TODO create a page with proper rights; this is only for admins! - return (qusr,user,lusr,E.Value pjac) + dbtProj = dbtProjId -- dbtProjFilteredPostId + -- dbtProj = (views _dbtProjRow . set _dbrOutput) =<< do + -- qusr <- view $ _dbtProjRow . resultQualUser + -- user <- view $ _dbtProjRow . resultUser + -- lusr <- preview $ _dbtProjRow . resultLmsUser + -- pjac <- preview $ _dbtProjRow . resultPrintAck + -- forMM_ (view $ _dbtProjFilter . _ltProjFilterMayAccess) $ \b -> do + -- euid <- encrypt $ user ^. _entityKey + -- guardM . lift . lift . fmap (== b) . hasReadAccessTo . urlRoute $ ForProfileDataR euid -- TODO create a page with proper rights; this is only for admins! + -- return (qusr,user,lusr,E.Value pjac) 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 ("blocked-due" , SortColumn $ queryQualUser >>> (E.^. QualificationUserBlockedDue)) - , single ("schedule-renew", SortColumn $ queryQualUser >>> (E.^. QualificationUserScheduleRenewal)) - , 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-datepin" , SortColumn $ queryLmsUser >>> (E.?. LmsUserDatePin)) - , single ("lms-received" , SortColumn $ queryLmsUser >>> (E.?. LmsUserReceived)) - , single ("lms-notified" , SortColumn $ queryLmsUser >>> (E.?. LmsUserNotified)) -- cannot include printJob acknowledge date - , single ("lms-ended" , SortColumn $ queryLmsUser >>> (E.?. LmsUserEnded)) + dbtSorting = mempty -- concat + -- [ 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 ("blocked-due" , SortColumn $ queryQualUser >>> (E.^. QualificationUserBlockedDue)) + -- , single ("schedule-renew", SortColumn $ queryQualUser >>> (E.^. QualificationUserScheduleRenewal)) + -- , 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-datepin" , SortColumn $ queryLmsUser >>> (E.?. LmsUserDatePin)) + -- , single ("lms-received" , SortColumn $ queryLmsUser >>> (E.?. LmsUserReceived)) + -- , single ("lms-notified" , SortColumn $ queryLmsUser >>> (E.?. LmsUserNotified)) -- cannot include printJob acknowledge date + -- , single ("lms-ended" , SortColumn $ queryLmsUser >>> (E.?. LmsUserEnded)) - ] - dbtFilter = mconcat - [ single ("may-access" , FilterProjected $ (_ltProjFilterMayAccess ?~) . getAny) - , 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 ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification nowaday)) - , single ("renewal-due" , FilterColumn $ \(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 - ) - , single ("lms-notified", FilterColumn . E.mkExactFilterLast $ views (to queryLmsUser) (E.isJust . (E.?. LmsUserNotified))) - ] - dbtFilterUI mPrev = mconcat - [ fltrUserNameEmailHdrUI MsgLmsUser 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) - , prismAForm (singletonFilter "lms-notified" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsNotified) - , if isNothing mbRenewal then mempty - else prismAForm (singletonFilter "renewal-due" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsRenewal) - ] - dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } + -- ] + dbtFilter = mempty -- concat + -- [ single ("may-access" , FilterProjected $ (_ltProjFilterMayAccess ?~) . getAny) ] + -- , 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 ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification nowaday)) + -- , single ("renewal-due" , FilterColumn $ \(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 + -- ) + -- , single ("lms-notified", FilterColumn . E.mkExactFilterLast $ views (to queryLmsUser) (E.isJust . (E.?. LmsUserNotified))) + -- ] + dbtFilterUI _mPrev = mempty -- mconcat + -- [ fltrUserNameEmailHdrUI MsgLmsUser 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) + -- , prismAForm (singletonFilter "lms-notified" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsNotified) + -- , if isNothing mbRenewal then mempty + -- else prismAForm (singletonFilter "renewal-due" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsRenewal) + -- ] + dbtStyle = def -- { dbsFilterLayout = defaultDBSFilterLayout } dbtCsvEncode = Just DBTCsvEncode { dbtCsvExportForm = pure () , dbtCsvDoEncode = \() -> C.map (doEncode' . view _2) @@ -509,70 +510,70 @@ postLmsR sid qsh = do -- , singletonMap LmsActRenewPin $ pure LmsActRenewPinData ] colChoices = mconcat - [ if not isAdmin then mempty else dbSelectIf (applying _2) id (return . view (resultUser . _entityKey)) (\r -> isJust $ r ^? resultLmsUser) -- TODO: refactor using function "is" - , colUserNameLinkHdr MsgLmsUser AdminUserR + [ --if not isAdmin then mempty else dbSelectIf (applying _2) id (return . view (resultUser . _entityKey)) (\r -> isJust $ r ^? resultLmsUser) -- TODO: refactor using function "is" + colUserNameLinkHdr MsgLmsUser AdminUserR , colUserEmail , sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) $ \( 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 "blocked-due") (i18nCell MsgTableQualificationBlockedDue & cellTooltip MsgTableQualificationBlockedTooltip - ) $ \( view $ resultQualUser . _entityVal . _qualificationUserBlockedDue -> b) -> qualificationBlockedCell b - , sortable (Just "schedule-renew")(i18nCell MsgTableQualificationNoRenewal & cellTooltip MsgTableQualificationNoRenewalTooltip - ) $ \( view $ resultQualUser . _entityVal . _qualificationUserScheduleRenewal -> b) -> ifIconCell (not b) IconNoNotification - , 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-datepin") (i18nLms MsgTableLmsDatePin) $ \(preview $ resultLmsUser . _entityVal . _lmsUserDatePin -> d) -> foldMap dateTimeCell d - , sortable (Just "lms-received") (i18nLms MsgTableLmsReceived) $ \(preview $ resultLmsUser . _entityVal . _lmsUserReceived -> d) -> foldMap dateTimeCell $ join d - --, sortable (Just "lms-notified") (i18nLms MsgTableLmsNotified) $ \(preview $ resultLmsUser . _entityVal . _lmsUserNotified -> d) -> foldMap dateTimeCell $ join d - , sortable (Just "lms-notified") (i18nLms MsgTableLmsNotified) $ \row -> - -- 4 Cases: - -- - No notification: LmsUserNotified == Nothing - -- - Email sent : LmsUserNotified == Just _ && PrintJobId == Nothing - -- - Letter printed : LmsUserNotified == Just _ && PrintJobId == Just _ - -- - Letter sent : LmsUserNotified == Just _ && PrintJobId == Just _ && PrintJobAcknowledged == Just _ - let notifyDate = join $ row ^? resultLmsUser . _entityVal . _lmsUserNotified - lmsident = row ^? resultLmsUser . _entityVal . _lmsUserIdent - recipient = row ^. hasUser - letterDates = row ^? resultPrintAck - lastLetterDate = headDef Nothing =<< letterDates - letterSent = isJust letterDates && (isNothing lastLetterDate || lastLetterDate >= notifyDate) -- was a letter attempted to send last (not 100% safe, if an email is sent after an unacknowledged letter) - notNotified = isNothing notifyDate - cIcon = iconFixedCell $ iconLetterOrEmail letterSent - cDate = if | not letterSent -> foldMap dateTimeCell notifyDate - | Just d <- lastLetterDate -> dateTimeCell d - | otherwise -> i18nCell MsgPrintJobUnacknowledged - lprLink :: Maybe (Route UniWorX) = lmsident <&> (\lid -> urlRoute (PrintCenterR, [("print-job-lmsid", toPathPiece lid)])) - cAckDates = case letterDates of - Just ackDates@(_:_:_) -> spacerCell <> modalCell [whamlet| -

- _{MsgPrintJobAcknowledgements} ^{userWidget recipient} -