chore(lms): lmsUser Overview reworked to newfound purpose. work in progress, compiles
This commit is contained in:
Steffen Jost
parent
06201bc22e
commit
2326b077c9
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user