diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index 157fd2add..4be9b857e 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -211,29 +211,120 @@ data LmsTableActionData = LmsActNotifyData deriving (Eq, Ord, Read, Show, Generic, Typeable) -mkLmsTable :: Entity Qualification -> DB (FormResult (LmsTableActionData, Set UserId), Widget) -mkLmsTable (Entity qid quali) = do +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 -- 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 - resultDBTable = DBTable{..} - where - dbtSQLQuery = runReaderT $ do - qualUser <- asks queryQualUser - user <- asks queryUser - lmsUser <- asks queryLmsUser - lift $ 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) - dbtRowKey = queryUser >>> (E.^. UserId) - dbtProj = dbtProjFilteredPostId - dbtColonnade = dbColonnade $ mconcat + dbtSQLQuery q = lmsTableQuery qid q <* E.where_ (restrict q) + dbtRowKey = queryUser >>> (E.^. UserId) + dbtProj = dbtProjFilteredPostId + 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 ("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 } + 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 LmsActRenewPin $ pure LmsActRenewPinData + ] + colChoices = mconcat [ colUserNameLinkHdr MsgTableLmsUser AdminUserR , colUserEmail , sortable (Just "valid-until") (i18nCell MsgTableQualificationValidUntil) $ \( view $ resultQualUser . _entityVal . _qualificationUserValidUntil -> d) -> dayCell d @@ -248,80 +339,8 @@ mkLmsTable (Entity qid quali) = do 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 ("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 } - 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 LmsTableActionData, DBFormResult UserId Bool (DBRow (Entity User))) -> FormResult (LmsTableActionData, 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 resultDBTableValidator resultDBTable - -getLmsR, postLmsR :: SchoolId -> QualificationShorthand -> Handler Html -getLmsR = postLmsR -postLmsR sid qsh = do - ((lmsRes, lmsTable), Entity qid quali) <- runDB $ do - qent <- getBy404 $ SchoolQualificationShort sid qsh - tbl <- mkLmsTable qent + psValidator = def + tbl <- mkLmsTable qent acts (const E.true) colChoices psValidator return (tbl, qent) formResult lmsRes $ \case