chore(lms): qualfication overview table stub working

messages/uniworx/utils/navigation/menu/de-de-formal.msg

@@ -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

messages/uniworx/utils/navigation/menu/en-eu.msg

@@ -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

src/Foundation/Navigation.hs

@@ -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)

src/Handler/LMS.hs

@@ -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))