Courselist for all courses

messages/de.msg

@@ -29,6 +29,7 @@ TermPlaceholder: W/S + vierstellige Jahreszahl
 LectureStart: Beginn Vorlesungen
 
 Course: Kurs
+CourseShort: Kürzel
 CourseNoCapacity: In diesem Kurs sind keine Plätze mehr frei.
 CourseRegisterOk: Sie wurden angemeldet
 CourseDeregisterOk: Sie wurden abgemeldet
@@ -40,6 +41,7 @@ CourseNewDupShort  tid@TermId courseShortHand@CourseShorthand: Kurs #{display ti
 CourseEditDupShort tid@TermId courseShortHand@CourseShorthand: Kurs #{display tid}-#{courseShortHand} konnte nicht geändert werden: Es gibt bereits einen anderen Kurs mit dem Kürzel #{courseShortHand} in diesem Semester.
 FFSheetName: Name
 TermCourseListHeading tid@TermId: Kursübersicht #{display tid}
+CourseListTitle: Alle Kurse
 TermCourseListTitle   tid@TermId: Kurse #{display tid}
 CourseNewHeading: Neuen Kurs anlegen
 CourseEditHeading tid@TermId courseShortHand@CourseShorthand: Kurs #{display tid}-#{courseShortHand} editieren

src/Foundation.hs

@@ -668,7 +668,7 @@ instance YesodBreadcrumbs UniWorX where
   breadcrumb (TermEditExistR tid)   = return ("Editieren" , Just $ TermCourseListR tid)
   breadcrumb (TermCourseListR (unTermKey -> tid)) = getMessageRender <&> \mr -> (mr $ ShortTermIdentifier tid, Just TermShowR)
 
-  breadcrumb  CourseListR                 = return ("Kurs"     , Just HomeR)
+  breadcrumb  CourseListR                 = return ("Kurse"    , Just HomeR)
   breadcrumb  CourseNewR                  = return ("Neu"      , Just CourseListR)
   breadcrumb (CourseR tid csh CShowR)     = return (CI.original csh, Just $ TermCourseListR tid)
   --         (CourseR tid csh CRegisterR) -- is POST only
@@ -744,7 +744,7 @@ defaultLinks = -- Define the menu items of the header.
   , NavbarAside $ MenuItem
       { menuItemLabel = "Kurse"
       , menuItemIcon = Just "calendar-alt"
-      , menuItemRoute = TermCurrentR -- should be CourseListActiveR or similar in the future
+      , menuItemRoute = CourseListR
       , menuItemAccessCallback' = return True
       }
   , NavbarAside $ MenuItem
@@ -964,7 +964,8 @@ pageHeading (TermEditExistR tid)
 pageHeading (TermCourseListR tid)
   = Just . i18nHeading . MsgTermCourseListHeading $ tid
 
---          CourseListR -- just a redirect to TermCurrentR
+pageHeading (CourseListR)
+  = Just $ i18nHeading $ MsgCourseListTitle
 pageHeading CourseNewR
   = Just $ i18nHeading MsgCourseNewHeading
 pageHeading (CourseR tid csh CShowR)

src/Handler/Course.hs

@@ -1,7 +1,12 @@
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE PartialTypeSignatures #-}
+{-# LANGUAGE RecordWildCards, NamedFieldPuns, TupleSections #-}
 {-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
@@ -18,6 +23,7 @@ import qualified Data.Text as T
 import Data.Function ((&))
 -- import Yesod.Form.Bootstrap3
 
+import qualified Data.Set as Set
 import qualified Data.Map as Map
 
 import Colonnade hiding (fromMaybe,bool)
@@ -28,8 +34,77 @@ import qualified Database.Esqueleto as E
 import qualified Data.UUID.Cryptographic as UUID
 
 
-getCourseListR :: Handler TypedContent
+type CourseTableData = DBRow (Entity Course, Int64)
-getCourseListR = redirect TermCurrentR
+
+colCourse :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
+colCourse = sortable (Just "course") (i18nCell MsgCourse)
+          $ \DBRow{ dbrOutput=(Entity cid Course{..}, _) } ->
+            anchorCell (CourseR courseTerm courseShorthand CShowR) [whamlet|#{display courseName}|]
+
+colCShort :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
+colCShort = sortable (Just "cshort") (i18nCell MsgCourseShort)
+          $ \DBRow{ dbrOutput=(Entity cid Course{..}, _) } ->
+            anchorCell (CourseR courseTerm courseShorthand CShowR) [whamlet|#{display courseShorthand}|]
+
+colTerm :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
+colTerm = sortable (Just "term") (i18nCell MsgTerm)
+          $ \DBRow{ dbrOutput=(Entity cid Course{..}, _) } ->
+            anchorCell (TermCourseListR courseTerm) [whamlet|#{display courseTerm}|]
+
+type CourseTableExpr = E.SqlExpr (Entity Course)
+
+makeCourseTable :: ( IsDBTable m x, ToSortable h, Functor h )
+                     => _ -> Colonnade h CourseTableData (DBCell m x) -> PSValidator m x -> Handler (DBResult m x)
+makeCourseTable whereClause colChoices psValidator = do
+  let dbtSQLQuery :: CourseTableExpr -> E.SqlQuery _
+      dbtSQLQuery course = do
+        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))
+        E.where_ $ whereClause (course,participants)
+        return (course, participants)
+      dbtProj :: DBRow _ -> MaybeT (ReaderT SqlBackend (HandlerT UniWorX IO)) CourseTableData
+      dbtProj = traverse $ \(course, E.Value participants) -> return (course, participants)
+  dbTable psValidator $ DBTable
+    { dbtSQLQuery
+    , dbtColonnade = colChoices
+    , dbtProj
+    , dbtSorting =
+        [ ( "course", SortColumn $ \course -> course E.^. CourseName)
+        , ( "cshort", SortColumn $ \course -> course E.^. CourseShorthand)
+        , ( "term"  , SortColumn $ \course -> course E.^. CourseTerm)
+        ]
+    , dbtFilter =
+        [ ( "course", FilterColumn $ \(course :: CourseTableExpr) criterias -> if
+                | Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool)
+                | otherwise          -> course E.^. CourseName `E.in_` E.valList (Set.toList criterias)
+          )
+        , ( "cshort", FilterColumn $ \(course :: CourseTableExpr) criterias -> if
+                | Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool)
+                | otherwise          -> course E.^. CourseShorthand `E.in_` E.valList (Set.toList criterias)
+          )
+        , ( "term"  , FilterColumn $ \(course :: CourseTableExpr) criterias -> if
+                | Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool)
+                | otherwise          -> course E.^. CourseTerm `E.in_` E.valList (Set.toList criterias)
+          )
+        ]
+    , dbtStyle = def
+    , dbtIdent = "courses" :: Text
+    }
+
+getCourseListR :: Handler Html
+getCourseListR = do -- TODO: KurseList aller Kurse mit Suchfunktion!
+  let colonnade = widgetColonnade $ mconcat
+        [ colCourse
+        , colCShort
+        , colTerm
+        ]
+      validator = def
+      whereClause = const $ E.val True
+  ctable <- makeCourseTable whereClause colonnade validator
+  defaultLayout $ do
+    setTitleI MsgCourseListTitle
+    ctable
 
 getTermCurrentR :: Handler Html
 getTermCurrentR = do
@@ -37,8 +112,7 @@ getTermCurrentR = do
   case fromNullable termIds of
     Nothing -> notFound
     (Just (maximum -> tid)) -> -- getTermCourseListR tid
-        redirect $ TermCourseListR tid -- redirect avids problematic breadcrumbs, headings, etc.
+        redirect $ TermCourseListR tid -- redirect avoids problematic breadcrumbs, headings, etc.
-
 
 getTermCourseListR :: TermId -> Handler Html
 getTermCourseListR tid = do

src/Handler/Sheet.hs

@@ -182,7 +182,7 @@ getSheetListR tid csh = do
           $ \(Entity _ Sheet{..}, _, _) -> cell $ formatTime SelFormatDateTime sheetActiveTo   >>= toWidget
       , sortable Nothing (i18nCell MsgSheetType)
           $ \(Entity _ Sheet{..}, _, _) -> textCell $ display sheetType
-      , sortable (Just "submitted") (i18nCell MsgSubmission)
+      , sortable Nothing (i18nCell MsgSubmission)
           $ \(Entity _ Sheet{..}, _, mbSub) -> case mbSub of
               Nothing -> mempty
               (Just (Entity sid Submission{..})) ->
@@ -210,17 +210,20 @@ getSheetListR tid csh = do
                    -> dbrOutput <$ guardM (lift $ (== Authorized) <$> evalAccessDB (CSheetR tid csh sheetName SShowR) False)
     , dbtSorting   = Map.fromList
       [ ( "name"
-        , SortColumn $ \(sheet `E.LeftOuterJoin` submission) -> sheet E.^. SheetName
+        , SortColumn $ \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetName
         )
       , ( "last-edit"
-        , SortColumn $ \(sheet `E.LeftOuterJoin` submission) -> E.sub_select . E.from $ \sheetEdit -> E.distinctOnOrderBy [E.desc $ sheetEdit E.?. SheetEditTime] $ do
+        , SortColumn $ \(sheet `E.LeftOuterJoin` _) -> E.sub_select . E.from $ \sheetEdit -> E.distinctOnOrderBy [E.desc $ sheetEdit E.?. SheetEditTime] $ do
             return $ sheetEdit E.?. SheetEditTime
         )
       , ( "submission-since"
-        , SortColumn $ \(sheet `E.LeftOuterJoin` submission) -> sheet E.^. SheetActiveFrom
+        , SortColumn $ \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetActiveFrom
         )
       , ( "submission-until"
-        , SortColumn $ \(sheet `E.LeftOuterJoin` submission) -> sheet E.^. SheetActiveTo
+        , SortColumn $ \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetActiveTo
+        )
+      , ( "rating"
+        , SortColumn $ \(_ `E.LeftOuterJoin` (submission `E.InnerJoin` submissionUser)) -> submission E.?. SubmissionRatingPoints
         )
       ]
     , dbtFilter    = Map.fromList