Convert CourseListR to dbTable

messages/de.msg

@@ -179,3 +179,7 @@ FileCorrectedDeleted: Korrigiert (gelöscht)
 RatingUpdated: Korrektur gespeichert
 RatingDeleted: Korrektur zurückgesetzt
 RatingFilesUpdated: Korrigierte Dateien überschrieben
+
+CourseMembers: Teilnehmer
+CourseMembersCount num@Int64: #{display num}
+CourseMembersCountLimited num@Int64 max@Int64: #{display num}/#{display max}

models

@@ -60,7 +60,7 @@ Course
     shorthand        Text
     term             TermId
     school           SchoolId
-    capacity         Int Maybe
+    capacity         Int64 Maybe
     -- canRegisterNow = maybe False (<= currentTime) registerFrom && maybe True (>= currentTime) registerTo
     registerFrom     UTCTime Maybe
     registerTo       UTCTime Maybe

src/Handler/Course.hs

@@ -7,6 +7,7 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedLists #-}
 
 module Handler.Course where
 
@@ -19,7 +20,9 @@ import Data.Function ((&))
 -- import Yesod.Form.Bootstrap3
 
 import Colonnade hiding (fromMaybe,bool)
-import Yesod.Colonnade
+-- import Yesod.Colonnade
+
+import qualified Database.Esqueleto as E
 
 import qualified Data.UUID.Cryptographic as UUID
 
@@ -37,45 +40,55 @@ getTermCurrentR = do
 
 
 getTermCourseListR :: TermId -> Handler Html
-getTermCourseListR tidini = do
-  (term,courses) <- runDB $ (,)
-      <$> get tidini
-      <*> selectList [CourseTerm ==. tidini] [Asc CourseShorthand]
-  when (isNothing term) $ do
-    addMessage "warning" [shamlet| Semester #{toPathPiece tidini} nicht gefunden. |]
-    redirect TermShowR
-  -- TODO: several runDBs per TableRow are probably too inefficient!
-  let colonnadeTerms = mconcat
-        [ headed "Kürzel" $ (\ckv ->
-            let c   = entityVal ckv
-                shd = courseShorthand c
-                tid = courseTerm c
-            in [whamlet| <a href=@{CourseR tid shd CShowR}>#{shd} |] )
---         , headed "Institut" $ [shamlet| #{course} |]
-        , headed "Beginn Anmeldung" $ fromString.(maybe "" formatTimeGerWD).courseRegisterFrom.entityVal
-        , headed "Ende Anmeldung"   $ fromString.(maybe "" formatTimeGerWD).courseRegisterTo.entityVal
-        , headed "Teilnehmer" $ (\ckv -> do
-              let cid = entityKey ckv
-              partiNum <- handlerToWidget $ runDB $ count [CourseParticipantCourse ==. cid]
-              [whamlet| #{show partiNum} |]
-            )
-        , headed " " $ (\ckv ->
-            let c   = entityVal ckv
-                shd = courseShorthand c
-                tid = courseTerm c
-            in do
-              adminLink <- handlerToWidget $ isAuthorized (CourseR tid shd CEditR) False
-              -- if (adminLink==Authorized) then linkButton "Ändern" BCWarning (CEditR tid shd) else ""
-              [whamlet|
-                $if adminLink == Authorized
-                  <a href=@{CourseR tid shd CEditR}>
-                    editieren
-              |]
-          )
+getTermCourseListR tid = do
+  void . runDB $ get404 tid -- Just ensure the term exists
+
+  let
+    tableData :: E.SqlExpr (Entity Course) -> E.SqlQuery (E.SqlExpr (Entity Course), E.SqlExpr (E.Value Int64))
+    tableData course = do
+      E.where_ $ course E.^. CourseTerm E.==. E.val tid
+      let
+        participants = E.sub_select . E.from $ \courseParticipant -> do
+          E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. course E.^. CourseId
+          return (E.countRows :: E.SqlExpr (E.Value Int64))
+      return (course, participants)
+    psValidator = def
+      & defaultSorting [("shorthand", SortAsc)]
+
+  coursesTable <- dbTable psValidator $ DBTable
+    { dbtSQLQuery  = tableData
+    , dbtColonnade = widgetColonnade $ mconcat
+        [ sortable (Just "shorthand") (textCell MsgCourse) $ anchorCell'
+            (\(Entity _ Course{..}, _) -> CourseR courseTerm courseShorthand CShowR)
+            (\(Entity _ Course{..}, _) -> toWidget courseShorthand)
+        , sortable (Just "register-from") (textCell MsgRegisterFrom) $ \(Entity _ Course{..}, _) -> textCell $ display courseRegisterFrom
+        , sortable (Just "register-to") (textCell MsgRegisterTo) $ \(Entity _ Course{..}, _) -> textCell $ display courseRegisterTo
+        , sortable (Just "members") (textCell MsgCourseMembers) $ \(Entity _ Course{..}, E.Value num) -> textCell $ case courseCapacity of
+            Nothing -> MsgCourseMembersCount num
+            Just max -> MsgCourseMembersCountLimited num max
         ]
-  let coursesTable = encodeWidgetTable tableSortable colonnadeTerms courses
+    , dbtSorting = [ ( "shorthand"
+                     , SortColumn $ \course -> course E.^. CourseShorthand
+                     )
+                   , ( "register-from"
+                     , SortColumn $ \course -> course E.^. CourseRegisterFrom
+                     )
+                   , ( "register-to"
+                     , SortColumn $ \course -> course E.^. CourseRegisterTo
+                     )
+                   , ( "members"
+                     , SortColumn $ \course -> E.sub_select . E.from $ \courseParticipant -> do
+                         E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. course E.^. CourseId
+                         return (E.countRows :: E.SqlExpr (E.Value Int64))
+                     )
+                   ]
+    , dbtFilter = []
+    , dbtAttrs = tableDefault
+    , dbtIdent = "courses" :: Text
+    }
+  
   defaultLayout $ do
-    setTitleI . MsgTermCourseListTitle $ tidini
+    setTitleI . MsgTermCourseListTitle $ tid
     $(widgetFile "courses")
 
 getCShowR :: TermId -> Text -> Handler Html
@@ -129,7 +142,7 @@ postCRegisterR tid csh = do
           actTime <- liftIO $ getCurrentTime
           regOk <- runDB $ do
             reg <- count [CourseParticipantCourse ==. cid]
-            if NTop (Just reg) < NTop (courseCapacity course)
+            if NTop (Just $ fromIntegral reg) < NTop (courseCapacity course)
               then -- current capacity has room
                 insertUnique $ CourseParticipant cid aid actTime
               else do -- no space left
@@ -260,7 +273,7 @@ data CourseForm = CourseForm
         , cfShort      :: Text
         , cfTerm       :: TermId
         , cfSchool     :: SchoolId
-        , cfCapacity   :: Maybe Int
+        , cfCapacity   :: Maybe Int64
         , cfSecret     :: Maybe Text
         , cfMatFree    :: Bool
         , cfRegFrom    :: Maybe UTCTime