diff --git a/models/lms.model b/models/lms.model index f71b041ed..7f6437260 100644 --- a/models/lms.model +++ b/models/lms.model @@ -31,7 +31,7 @@ Qualification -- - Flag "interner Mitarbeiter" wird von Know-How ignoriert / nicht ausgewertet (legacy) QualificationPrecondition - qualification QualificationId -- AND: not unique, ie. qualification can have multiple required preconditions + qualification QualificationId OnDeleteCascade OnUpdateCascade -- AND: not unique, ie. qualification can have multiple required preconditions required [QualificationId] -- OR : alternatives, any one will suffice continuous Bool -- expiring precondition removes qualification deriving Generic @@ -45,7 +45,7 @@ QualificationEdit deriving Generic QualificationUser - user UserId + user UserId OnDeleteCascade OnUpdateCascade qualification QualificationId OnDeleteCascade OnUpdateCascade validUntil Day lastRefresh Day -- lastRefresh > validUntil possible, if Qualification^elearningOnly == False @@ -90,7 +90,7 @@ QualificationUser LmsUser qualification QualificationId OnDeleteCascade OnUpdateCascade - user UserId + user UserId OnDeleteCascade OnUpdateCascade ident LmsIdent -- must be unique accross all LMS courses! pin Text resetPin Bool default=false -- should pin be reset? @@ -123,7 +123,7 @@ LmsResult -- Logs all processed rows from LmsUserlist and LmsResult LmsAudit - qualification QualificationId + qualification QualificationId OnDeleteCascade OnUpdateCascade ident LmsIdent notificationType LmsStatus -- LmsBlocked Day | LmsSuccess Day received UTCTime -- timestamp from LmsUserlist/LmsResult diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index 2f90ebfe7..d2fda6747 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -133,45 +133,35 @@ getLmsEditR = postLmsEditR postLmsEditR = error "TODO" -type LmsResultTableExpr = ( E.SqlExpr (Entity Qualification) - `E.InnerJoin` E.SqlExpr (Entity LmsResult) - ) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity LmsUser)) - `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User)) +type LmsTableExpr = ( E.SqlExpr (Entity QualificationUser) + `E.InnerJoin` E.SqlExpr (Entity User) + ) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity LmsUser)) -queryQualification :: LmsResultTableExpr -> E.SqlExpr (Entity Qualification) -queryQualification = $(sqlIJproj 2 1) . $(sqlLOJproj 3 1) +queryQualUser :: LmsTableExpr -> E.SqlExpr (Entity QualificationUser) +queryQualUser = $(sqlIJproj 2 1) . $(sqlLOJproj 2 1) -queryLmsResult :: LmsResultTableExpr -> E.SqlExpr (Entity LmsResult) -queryLmsResult = $(sqlIJproj 2 2) . $(sqlLOJproj 3 1) +queryUser :: LmsTableExpr -> E.SqlExpr (Entity User) +queryUser = $(sqlIJproj 2 2) . $(sqlLOJproj 2 1) -queryLmsUser :: LmsResultTableExpr -> E.SqlExpr (Maybe (Entity LmsUser)) -queryLmsUser = $(sqlLOJproj 3 2) +queryLmsUser :: LmsTableExpr -> E.SqlExpr (Maybe (Entity LmsUser)) +queryLmsUser = $(sqlLOJproj 2 2) -queryUser :: LmsResultTableExpr -> E.SqlExpr (Maybe (Entity User)) -queryUser = $(sqlLOJproj 3 3) +type LmsTableData = DBRow (Entity QualificationUser, Entity User, Maybe (Entity LmsUser)) -type LmsResultTableData = DBRow (Entity Qualification, Entity LmsResult, Maybe (Entity LmsUser), Maybe (Entity User)) +resultQualUser :: Lens' LmsTableData (Entity QualificationUser) +resultQualUser = _dbrOutput . _1 -instance HasEntity LmsResultTableData LmsResult where - hasEntity = _dbrOutput . _2 +resultUser :: Lens' LmsTableData (Entity User) +resultUser = _dbrOutput . _2 -{- MaybeHasUser only! -instance HasUser LmsResultTableData where - hasUser = resultUser . _entityVal --} - -resultQualification :: Lens' LmsResultTableData (Entity Qualification) -resultQualification = _dbrOutput . _1 - -resultLmsResult :: Lens' LmsResultTableData (Entity LmsResult) -resultLmsResult = _dbrOutput . _2 - -resultLmsUser :: Traversal' LmsResultTableData (Entity LmsUser) +resultLmsUser :: Traversal' LmsTableData (Entity LmsUser) resultLmsUser = _dbrOutput . _3 . _Just -resultUser :: Traversal' LmsResultTableData (Entity User) -resultUser = _dbrOutput . _4 . _Just +instance HasEntity LmsTableData User where + hasEntity = resultUser +instance HasUser LmsTableData where + hasUser = resultUser . _entityVal mkLmsTable :: QualificationId -> DB (Any, Widget) mkLmsTable qid = do @@ -179,44 +169,47 @@ mkLmsTable qid = do resultDBTable = DBTable{..} where dbtSQLQuery = runReaderT $ do - qualification <- asks queryQualification - lmsResult <- asks queryLmsResult - lmsUser <- asks queryLmsUser - user <- asks queryUser + qualUser <- asks queryQualUser + user <- asks queryUser + lmsUser <- asks queryLmsUser + lift $ do - E.on $ qualification E.^. QualificationId E.==. lmsResult E.^. LmsResultQualification - E.on $ lmsUser E.?. LmsUserIdent E.==. E.just (lmsResult E.^. LmsResultIdent) - E.on $ lmsUser E.?. LmsUserUser E.==. user E.?. UserId - E.where_ $ qualification E.^. QualificationId E.==. E.val qid - return (qualification, lmsResult, lmsUser, user) - dbtRowKey = queryLmsResult >>> (E.^. LmsResultId) + E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser + E.on $ user E.^. UserId E.=?. lmsUser E.?. LmsUserUser + E.where_ $ E.val qid E.==. qualUser E.^. QualificationUserQualification + E.&&. E.val qid E.=?. lmsUser E.?. LmsUserQualification + return (qualUser, user, lmsUser) + dbtRowKey = queryUser >>> (E.^. UserId) dbtProj = dbtProjFilteredPostId -- TODO: or dbtProjSimple what is the difference? dbtColonnade = dbColonnade $ mconcat - [ sortable (Just "user") (i18nCell MsgTableLmsUser) $ -- \(preview resultUser -> entuser) -> maybeCell entuser (cellHasUserLink AdminUserR) - foldMap (cellHasUserLink AdminUserR) . (^? resultUser) - , sortable (Just "email") (i18nCell MsgTableEmail) $ -- \(preview $ resultUser . _entityVal -> user) -> maybeCell user cellHasEMail - foldMap cellHasEMail . (^? resultUser) - , sortable (Just csvLmsIdent) (i18nCell MsgTableLmsIdent) $ \(view $ resultLmsResult . _entityVal . _lmsResultIdent . _getLmsIdent -> ident) -> textCell ident - , sortable (Just csvLmsSuccess) (i18nCell MsgTableLmsSuccess) $ \(view $ resultLmsResult . _entityVal . _lmsResultSuccess -> success) -> dayCell success + [ sortable (Just "user") (i18nCell MsgTableLmsUser) $ cellHasUserLink AdminUserR + , sortable (Just "email") (i18nCell MsgTableEmail) cellHasEMail + --, sortable (Just csvLmsIdent) (i18nCell MsgTableLmsIdent) $ \(preview $ resultLmsUser . _entityVal . _lmsUserIdent . _getLmsIdent -> ident) -> textCell ident + --, sortable (Just csvLmsSuccess) (i18nCell MsgTableLmsSuccess) $ \(view $ resultLmsResult . _entityVal . _lmsResultSuccess -> success) -> dayCell success ] -- TODO: add more columns for manual debugging view !!! dbtSorting = Map.fromList - [ ("user" , SortColumn $ queryUser >>> (E.?. UserDisplayName)) - , ("email" , SortColumn $ queryUser >>> (E.?. UserEmail)) - , (csvLmsIdent , SortColumn $ queryLmsResult >>> (E.^. LmsResultIdent)) - -- , (csvLmsSuccess, SortColumn $ queryLmsResult >>> (E.^. LmsResultSuccess)) - , (csvLmsSuccess, SortColumn $ views (to queryLmsResult) (E.^. LmsResultSuccess)) + [ ("user" , SortColumn $ queryUser >>> (E.^. UserDisplayName)) + , ("email" , SortColumn $ queryUser >>> (E.^. UserEmail)) + -- + -- , (csvLmsIdent , SortColumn $ queryLmsUser >>> (E.^. LmsResultIdent)) + -- , (csvLmsSuccess, SortColumn $ queryLmsResult >>> (E.^. LmsResultSuccess)) + -- , (csvLmsSuccess, SortColumn $ views (to queryLmsResult) (E.^. LmsResultSuccess)) ] - dbtFilter = Map.fromList - [ ("user" , FilterColumn . E.mkContainsFilterWith Just $ views (to queryUser) (E.?. UserDisplayName)) - , ("email" , FilterColumn . E.mkContainsFilterWith Just $ views (to queryUser) (E.?. UserEmail)) - , (csvLmsIdent , FilterColumn . E.mkContainsFilterWith LmsIdent $ views (to queryLmsResult) (E.^. LmsResultIdent)) - , (csvLmsSuccess, FilterColumn . E.mkExactFilter $ views (to queryLmsResult) (E.^. LmsResultSuccess)) + -- where single = uncurry Map.singleton + dbtFilter = mconcat + [ single $ fltrUserNameEmail queryUser + --("user" , FilterColumn . E.mkContainsFilterWith Just $ views (to queryUser) (E.^. UserDisplayName)) + -- , ("email" , FilterColumn . E.mkContainsFilterWith Just $ views (to queryUser) (E.^. UserEmail)) + -- , (csvLmsIdent , FilterColumn . E.mkContainsFilterWith LmsIdent $ views (to queryLmsResult) (E.^. LmsResultIdent)) + -- , (csvLmsSuccess, FilterColumn . E.mkExactFilter $ views (to queryLmsResult) (E.^. LmsResultSuccess)) ] - dbtFilterUI = \mPrev -> mconcat - [ 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) + where single = uncurry Map.singleton + dbtFilterUI mPrev = mconcat + [ 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 } dbtParams = def @@ -235,7 +228,7 @@ getLmsR = postLmsR postLmsR sid qsh = do (lmsTable, quali) <- runDB $ do Entity qid quali <- getBy404 $ SchoolQualificationShort sid qsh - tbl <- view _2 <$> mkLmsTable qid + tbl <- view _2 <$> mkLmsTable qid return (tbl, quali) let heading = citext2widget $ qualificationName quali siteLayout heading $ do