chore(lms): qualfication overview table stub working
This commit is contained in:
Steffen Jost
parent
b9bda938b4
commit
577399199a
@ -123,7 +123,7 @@ MenuCourseEventNew: Neuer Kurstermin
|
||||
MenuCourseEventEdit: Kurstermin bearbeiten
|
||||
MenuLanguage: Sprache
|
||||
|
||||
MenuQualification: Qualifkationen
|
||||
MenuQualifications: Qualifkationen
|
||||
MenuLms: Schnittstelle E-Lernen
|
||||
MenuLmsEdit: Bearbeiten E-Lernen
|
||||
MenuLmsUsers: Export E-Lernen Benutzer
|
||||
|
||||
@ -124,7 +124,7 @@ MenuCourseEventNew: New course occurrence
|
||||
MenuCourseEventEdit: Edit course occurrence
|
||||
MenuLanguage: Language
|
||||
|
||||
MenuQualification: Qualifcations
|
||||
MenuQualifications: Qualifcations
|
||||
MenuLms: Interface E-Learning
|
||||
MenuLmsEdit: Edit E-Learning
|
||||
MenuLmsUsers: Download E-Learning Users
|
||||
|
||||
@ -133,7 +133,7 @@ breadcrumb HealthR = i18nCrumb MsgMenuHealth Nothing
|
||||
breadcrumb InstanceR = i18nCrumb MsgMenuInstance Nothing
|
||||
breadcrumb StatusR = i18nCrumb MsgMenuHealth Nothing -- never displayed
|
||||
|
||||
breadcrumb LmsAllR = i18nCrumb MsgMenuQualification Nothing
|
||||
breadcrumb LmsAllR = i18nCrumb MsgMenuQualifications Nothing
|
||||
breadcrumb (LmsSchoolR ssh ) = useRunDB . maybeT (i18nCrumb MsgBreadcrumbSchool . Just $ SchoolListR) $ do -- redirect only, used in other breadcrumbs
|
||||
guardM . lift . existsBy . UniqueSchoolShorthand $ unSchoolKey ssh
|
||||
return (CI.original $ unSchoolKey ssh, Just LmsAllR)
|
||||
|
||||
@ -35,7 +35,64 @@ import Handler.LMS.Userlist as Handler.LMS
|
||||
import Handler.LMS.Result as Handler.LMS
|
||||
|
||||
getLmsAllR :: Handler Html
|
||||
getLmsAllR = error "TODO"
|
||||
getLmsAllR = do
|
||||
lmsTable <- runDB $ do
|
||||
view _2 <$> mkLmsAllTable
|
||||
siteLayoutMsg MsgMenuQualifications $ do
|
||||
setTitleI MsgMenuQualifications
|
||||
$(widgetFile "lms-all")
|
||||
|
||||
x :: Int64
|
||||
x = 42
|
||||
|
||||
type AllQualificationTableData = DBRow (Entity Qualification, E.Value Int64)
|
||||
queryAllQualification :: Lens' AllQualificationTableData Qualification
|
||||
queryAllQualification = _dbrOutput . _1 . _entityVal
|
||||
|
||||
mkLmsAllTable :: DB (Any, Widget)
|
||||
mkLmsAllTable = do
|
||||
let
|
||||
resultDBTable = DBTable{..}
|
||||
where
|
||||
dbtSQLQuery = runReaderT $ do
|
||||
quali <- view id
|
||||
--count
|
||||
return (quali, E.val x)
|
||||
dbtRowKey = (E.^. QualificationId)
|
||||
dbtProj = dbtProjFilteredPostId -- TODO: or dbtProjSimple what is the difference?
|
||||
dbtColonnade = dbColonnade $ mconcat
|
||||
[ colSchool $ queryAllQualification . _qualificationSchool
|
||||
, sortable (Just "qualification-shorthand") (i18nCell MsgTableLmsIdent) $ \(view queryAllQualification -> quali) ->
|
||||
let qsh = qualificationShorthand quali in
|
||||
anchorCell (LmsR (qualificationSchool quali) qsh) $ toWgt qsh
|
||||
] -- TODO: add more columns for manual debugging view !!!
|
||||
dbtSorting = mconcat
|
||||
[
|
||||
sortSchool $ to (E.^. QualificationSchool)
|
||||
, singletonMap "qualification-shorthand" $ SortColumn (E.^. QualificationShorthand)
|
||||
]
|
||||
dbtFilter = mconcat
|
||||
[
|
||||
fltrSchool $ to (E.^. QualificationSchool)
|
||||
]
|
||||
dbtFilterUI = mconcat
|
||||
[
|
||||
fltrSchoolUI
|
||||
]
|
||||
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
|
||||
dbtParams = def
|
||||
dbtIdent :: Text
|
||||
dbtIdent = "qualification-overview"
|
||||
dbtCsvEncode = noCsvEncode
|
||||
dbtCsvDecode = Nothing
|
||||
dbtExtraReps = []
|
||||
|
||||
resultDBTableValidator = def
|
||||
& defaultSorting [SortAscBy "school", SortAscBy "qualification-shorthand"]
|
||||
dbTable resultDBTableValidator resultDBTable
|
||||
|
||||
|
||||
|
||||
|
||||
getLmsSchoolR :: SchoolId -> Handler Html
|
||||
getLmsSchoolR ssh = redirect (LmsAllR, [("qualification-school", toPathPiece ssh)])
|
||||
@ -46,113 +103,6 @@ getLmsEditR = postLmsEditR
|
||||
postLmsEditR = error "TODO"
|
||||
|
||||
|
||||
|
||||
{- --redirect with filering
|
||||
getLmsR :: SchoolId -> QualificationShorthand -> Handler Html
|
||||
getLmsR ssh qsh = redirect (LmsAllR, [("qualification-school" , toPathPiece ssh)
|
||||
,("qualification-shorthand", toPathPiece qsh)
|
||||
])
|
||||
-}
|
||||
|
||||
{-
|
||||
data LmsUserTableCsv = LmsUserTableCsv -- for csv export only
|
||||
{ csvLmsUserIdent :: LmsIdent
|
||||
, csvLmsUserPin :: Text
|
||||
, csvLmsUserReset, cvsLmsUserRemove, cvsLmsUserIntern :: Int
|
||||
}
|
||||
|
||||
data LmsCsvExportData = LmsCsvExportData
|
||||
|
||||
type LmsUserTableExpr = E.SqlExpr (Entity LmsUser)
|
||||
`E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User))
|
||||
|
||||
type LmsUserTableData = DBRow ( Entity LmsUser
|
||||
, Maybe (Entity User)
|
||||
)
|
||||
|
||||
queryLmsUser :: Getter LmsUserTableExpr (E.SqlExpr (Entity LmsUser))
|
||||
queryLmsUser = to $(E.sqlLOJproj 2 1)
|
||||
|
||||
queryUser :: Getter LmsUserTableExpr (E.SqlExpr (Maybe (Entity User)))
|
||||
queryUser = to $(E.sqlLOJproj 2 2)
|
||||
|
||||
resultLmsUser :: Lens' LmsUserTableData (Entity LmsUser)
|
||||
resultLmsUser = _dbrOutput . _1
|
||||
|
||||
resultUser :: Lens' LmsUserTableData (Maybe (Entity User))
|
||||
resultUser = _dbrOutput . _2
|
||||
|
||||
|
||||
getLmsR, postLmsR:: SchoolId -> QualificationShorthand -> Handler Html
|
||||
getLmsR = postLmsR
|
||||
postLmsR sid qsh = do
|
||||
_qid <- runDB . getKeyBy404 $ SchoolQualificationShort sid qsh
|
||||
-- TODO !!! filter table by qid !!!
|
||||
|
||||
dbtCsvName <- csvLmsUserFilename
|
||||
let dbtIdent = "lmsUsers" :: Text
|
||||
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
|
||||
dbtSQLQuery = runReaderT $ do
|
||||
lmsUser <- view queryLmsUser
|
||||
user <- view queryUser
|
||||
lift $ do
|
||||
E.on $ E.just (lmsUser E.^. LmsUserUser) E.==. user E.?. UserId
|
||||
-- TODO where?
|
||||
return (lmsUser, user)
|
||||
dbtRowKey = queryLmsUser >>> (E.^. LmsUserId)
|
||||
dbtProj = dbtProjSimple $ \(lmsUser, user) -> do
|
||||
-- return ("abcdefgh", "12345678", False, False, True)
|
||||
return ( lmsUser E.^. LmsUserIdent
|
||||
, lmsUser E.^. LmsUserPin
|
||||
, lmsUser E.^. LmsUserResetPin
|
||||
, lmsUser E.^. LmsUserResetPin
|
||||
-- , True) -- works, so we need a simple type here indeed
|
||||
, isJust $ E.unValue (user E.?. UserCompanyPersonalNumber))
|
||||
dbtColonnade = mempty --TODO
|
||||
dbtSorting = mempty
|
||||
dbtFilter = mempty
|
||||
dbtFilterUI = mempty
|
||||
dbtParams = def
|
||||
-- TODO: wip, for reference, see e.g. Handler.Course.Users or Handler.Exam.
|
||||
dbtCsvEncode = do
|
||||
return $ DBTCsvEncode
|
||||
{ dbtCsvExportForm = def
|
||||
, dbtCsvDoEncode = \LmsCsvExportData{} -> C.mapM $ \(_lmsUserTableId, row) -> do
|
||||
mitarbeiter <- return 1
|
||||
return $ LmsUserTableCsv
|
||||
(row ^. resultUser . _entityVal . _lmsUserIdent)
|
||||
(row ^. resultUser . _entityVal . _lmsUserPin)
|
||||
(row ^. resultUser . _entityVal . _lmsUserResetPin . to fromEnum)
|
||||
(row ^. resultUser . _entityVal . _lmsUserDelete . to fromEnum)
|
||||
mitarbeiter
|
||||
, dbtCsvName
|
||||
, dbtCsvNoExportData = Nothing
|
||||
, dbtCsvHeader = def -- return . Vector.filter csvColumns' . userTableCsvHeader showSex tutorials sheets . fromMaybe def
|
||||
, dbtCsvExampleData = Nothing
|
||||
}
|
||||
-- TODO wip, for reference see e.g. Handler.Exam.Users
|
||||
dbtCsvDecode = Nothing -- Just DBTCsvDecode
|
||||
-- { dbtCsvRowKey = _1
|
||||
-- , dbtCsvComputeActions = _2
|
||||
-- , dbtCsvClassifyAction = _3
|
||||
-- , dbtCsvCoarsenActionClass = _4
|
||||
-- , dbtCsvValidateActions = _5
|
||||
-- , dbtCsvExecuteActions = _6 -- <- actions based on sent data here
|
||||
-- , dbtCsvRenderKey = _7
|
||||
-- , dbtCsvRenderActionClass = _8
|
||||
-- , dbtCsvRenderException = _9
|
||||
-- }
|
||||
psValidator = def
|
||||
lmsTable = dbTable psValidator DBTable{..}
|
||||
|
||||
let lmsTable = [whamlet|TODO|] -- TODO: remove me, just for debugging
|
||||
siteLayoutMsg MsgMenuLms $ do
|
||||
setTitleI MsgMenuLms
|
||||
$(widgetFile "lms")
|
||||
-}
|
||||
|
||||
--- old above, new below
|
||||
|
||||
type LmsResultTableExpr = ( E.SqlExpr (Entity Qualification)
|
||||
`E.InnerJoin` E.SqlExpr (Entity LmsResult)
|
||||
) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity LmsUser))
|
||||
|
||||
Loading…
Reference in New Issue
Block a user