chore(lms): demo subSelect in dbtSQLQuery vs sqlCell

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

@@ -124,7 +124,7 @@ MenuCourseEventEdit: Kurstermin bearbeiten
 MenuLanguage: Sprache
 
 MenuQualifications: Qualifkationen
-MenuLms: Schnittstelle E-Lernen
+MenuLms: E-Lernen
 MenuLmsEdit: Bearbeiten E-Lernen
 MenuLmsUsers: Export E-Lernen Benutzer
 MenuLmsUserlist: Melden E-Lernen Benutzer

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

@@ -125,7 +125,7 @@ MenuCourseEventEdit: Edit course occurrence
 MenuLanguage: Language
 
 MenuQualifications: Qualifcations
-MenuLms: Interface E-Learning
+MenuLms: E-Learning
 MenuLmsEdit: Edit E-Learning
 MenuLmsUsers: Download E-Learning Users
 MenuLmsUserlist: Upload E-Learning Users 

models/lms.model

@@ -38,13 +38,13 @@ QualificationPrecondition
 -- TODO: connect Qualification with Exams!
 
 QualificationEdit
-  user            User
+  user            UserId
   time            UTCTime
   qualification   QualificationId OnDeleteCascade OnUpdateCascade
   deriving Generic
 
 QualificationUser
-  user              User
+  user              UserId
   qualification     QualificationId OnDeleteCascade OnUpdateCascade
   validUntil        UTCTime
   lastRefresh       UTCTime                     -- lastRefresh > validUntil possible, if Qualification^elearningOnly == False

src/Database/Esqueleto/Utils/TH.hs

@@ -3,6 +3,7 @@
 module Database.Esqueleto.Utils.TH
   ( SqlIn(..)
   , sqlInTuple, sqlInTuples
+  , _unValue
   , unValueN, unValueNIs
   , sqlIJproj, sqlLOJproj, sqlFOJproj
   ) where
@@ -19,6 +20,7 @@ import Language.Haskell.TH
 import Data.List (foldr1, foldl)
 
 import Utils.TH
+import Control.Lens.Iso (Iso', iso)
 
 class E.SqlSelect a r => SqlIn a r | a -> r, r -> a where
   sqlIn :: a -> [r] -> E.SqlExpr (E.Value Bool)
@@ -60,6 +62,10 @@ sqlInTuple arity = do
       ]
     ]
 
+
+_unValue :: Iso' (E.Value v) v
+_unValue = iso E.unValue E.Value
+
 -- | Generic unValuing of Tuples of Values, i.e.
 --
 --   > $(unValueN 3) :: (E.Value a, E.Value b, E.Value c) -> (a,b,c)

src/Handler/LMS.hs

@@ -1,8 +1,6 @@
 {-# OPTIONS_GHC -fno-warn-orphans #-}      -- needed for HasEntity instances
 {-# OPTIONS -Wno-unused-top-binds #-}      -- TODO: remove me, for debugging only
-{-# OPTIONS -Wno-unused-imports #-}        -- TODO: remove me, for debugging only
+{-# LANGUAGE TypeApplications #-}
-{-# OPTIONS -Wno-redundant-constraints #-} -- TODO: remove me, for debugging only
-
 
 module Handler.LMS
   ( getLmsAllR
@@ -20,12 +18,13 @@ module Handler.LMS
 import Import
 
 import Handler.Utils
-import Handler.Utils.Csv
+-- import Handler.Utils.Csv
 import Handler.Utils.LMS
 
 import qualified Data.Map as Map
-import qualified Data.Csv as Csv
+-- import qualified Data.Csv as Csv
-import qualified Data.Conduit.List as C
+-- import qualified Data.Conduit.List as C
+import qualified Database.Esqueleto.Experimental as Ex -- needs TypeApplications Lang-Pragma
 import qualified Database.Esqueleto.Legacy as E
 import qualified Database.Esqueleto.Utils as E
 import Database.Esqueleto.Utils.TH
@@ -34,6 +33,10 @@ import Handler.LMS.Users    as Handler.LMS
 import Handler.LMS.Userlist as Handler.LMS
 import Handler.LMS.Result   as Handler.LMS
 
+
+getLmsSchoolR :: SchoolId -> Handler Html
+getLmsSchoolR ssh = redirect (LmsAllR, [("qualification-overview-school", toPathPiece ssh)])
+
 getLmsAllR :: Handler Html
 getLmsAllR = do
   lmsTable <- runDB $ do
@@ -42,10 +45,7 @@ getLmsAllR = do
     setTitleI MsgMenuQualifications
     $(widgetFile "lms-all")
 
-x :: Int64
+type AllQualificationTableData = DBRow (Entity Qualification, Ex.Value Word64)
-x = 42
-
-type AllQualificationTableData = DBRow (Entity Qualification, E.Value Int64)
 queryAllQualification :: Lens' AllQualificationTableData Qualification
 queryAllQualification = _dbrOutput . _1 . _entityVal 
 
@@ -54,22 +54,37 @@ mkLmsAllTable = do
   let
     resultDBTable = DBTable{..}
       where
-        dbtSQLQuery = runReaderT $ do
+        dbtSQLQuery quali = do          
-          quali <- view id
+          -- let x = E.val (42::Word64)
-          --count
+          --
-          return (quali, E.val x)
+          -- x <- pure . E.subSelectCount . E.from $ \quser ->
+          --        E.where_ $ quser E.^. QualificationUserQualification E.==. quali E.^. QualificationId
+          --
+          x <- pure . Ex.subSelectCount $ do 
+                  quser <- Ex.from $ Ex.table @QualificationUser
+                  Ex.where_ $ quser Ex.^. QualificationUserQualification Ex.==. quali Ex.^. QualificationId                  
+          return (quali, 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) -> 
+          , sortable (Just "qualification-short") (i18nCell MsgTableLmsIdent) $ \(view queryAllQualification -> quali) -> 
               let qsh = qualificationShorthand quali in 
               anchorCell (LmsR (qualificationSchool quali) qsh) $ toWgt qsh
+          , sortable Nothing (i18nCell MsgTableLmsUser) $ \(view $ _dbrOutput . _1 . _entityKey -> qualid) -> sqlCell $ do
+              num <- fmap (maybe 0 (max 0 . Ex.unValue) . listToMaybe) .
+                Ex.select $ do 
+                  quser <- Ex.from $ Ex.table @QualificationUser
+                  Ex.where_ $ quser Ex.^. QualificationUserQualification Ex.==. Ex.val qualid
+                  pure Ex.countRows              
+              return $ word2widget num
+          , sortable Nothing (i18nCell MsgMenuAdminTest) $ \(view $ _dbrOutput . _2 . _unValue -> n) -> wgtCell $ word2widget n
+
           ] -- TODO: add more columns for manual debugging view !!!
         dbtSorting = mconcat
           [
             sortSchool $ to (E.^. QualificationSchool)
-          , singletonMap "qualification-shorthand" $ SortColumn (E.^. QualificationShorthand)
+          , singletonMap "qualification-short" $ SortColumn (E.^. QualificationShorthand)
           ]
         dbtFilter = mconcat
           [
@@ -88,16 +103,11 @@ mkLmsAllTable = do
         dbtExtraReps = []
 
     resultDBTableValidator = def
-      & defaultSorting [SortAscBy "school", SortAscBy "qualification-shorthand"]
+      & defaultSorting [SortAscBy "school", SortAscBy "qualification-short"]
   dbTable resultDBTableValidator resultDBTable
 
 
 
-
-getLmsSchoolR :: SchoolId -> Handler Html
-getLmsSchoolR ssh = redirect (LmsAllR, [("qualification-school", toPathPiece ssh)])
-
-
 getLmsEditR, postLmsEditR :: SchoolId -> QualificationShorthand -> Handler Html
 getLmsEditR = postLmsEditR 
 postLmsEditR = error "TODO"

src/Utils.hs

@@ -301,6 +301,13 @@ citext2widget t = [whamlet|#{CI.original t}|]
 str2widget :: String -> WidgetFor site ()
 str2widget s = [whamlet|#{s}|]
 
+int2widget :: Int64 -> WidgetFor site ()
+int2widget i = [whamlet|#{tshow i}|]
+
+word2widget :: Word64 -> WidgetFor site ()
+word2widget i = [whamlet|#{tshow i}|]
+
+
 withFragment :: Monad m => MForm m (a, WidgetFor site ()) -> Markup -> MForm m (a, WidgetFor site ())
 withFragment form html = flip fmap form $ over _2 (toWidget html >>)
 

templates/lms-all.hamlet

@@ -0,0 +1 @@
+^{lmsTable}

test/Database/Fill.hs

@@ -457,8 +457,18 @@ fillDb = do
   for_ [jost] $ \uid ->
     void . insert' $ UserSchool uid avn False
 
-  qid_f   <- insert' $ Qualification avn "F" "Vorfeldführerschein"  Nothing (Just 24) (Just $ 5 * 12) Nothing True 
+  qid_f  <- insert' $ Qualification avn "F" "Vorfeldführerschein"  Nothing (Just 24) (Just $ 5 * 12) Nothing True 
-  _qid_r  <- insert' $ Qualification avn "R" "Rollfeldführerschein" Nothing (Just 24) (Just $ 5 * 12) Nothing False
+  qid_r  <- insert' $ Qualification avn "R" "Rollfeldführerschein" Nothing (Just 24) (Just $ 5 * 12) Nothing False
+  qid_l  <- insert' $ Qualification ifi "L" "Lehrbefähigung"       Nothing Nothing   (Just $ 5 * 12) Nothing False
+  void . insert' $ QualificationUser jost       qid_f now now now -- TODO: better dates!
+  void . insert' $ QualificationUser gkleen     qid_f now now now 
+  void . insert' $ QualificationUser maxMuster  qid_f now now now 
+  void . insert' $ QualificationUser svaupel    qid_f now now now
+  void . insert' $ QualificationUser gkleen     qid_r now now now 
+  void . insert' $ QualificationUser maxMuster  qid_r now now now 
+  void . insert' $ QualificationUser fhamann    qid_r now now now
+  void . insert' $ QualificationUser svaupel    qid_l now now now
+  void . insert' $ QualificationUser gkleen     qid_l now now now 
   void . insert' $ LmsResult qid_f (LmsIdent "hijklmn") (addBDays (-1) $ utctDay now) now 
   void . insert' $ LmsResult qid_f (LmsIdent "opqgrs" ) (addBDays (-2) $ utctDay now) now 
   void . insert' $ LmsResult qid_f (LmsIdent "pqgrst" ) (addBDays (-3) $ utctDay now) now 
@@ -468,6 +478,7 @@ fillDb = do
   void . insert' $ LmsUser qid_f jost     (LmsIdent "ijk"    ) "123" False Nothing now Nothing Nothing
   void . insert' $ LmsUser qid_f svaupel  (LmsIdent "abcdefg") "abc" False (Just True)  now (Just now) Nothing
   void . insert' $ LmsUser qid_f gkleen   (LmsIdent "hijklmn") "@#!" True  (Just False) now (Just now) Nothing
+  
   let
     sdBsc = StudyDegreeKey' 82
     sdMst = StudyDegreeKey' 88