From e9b504473c5ae90f948df71c474cf5a6bf7cb334 Mon Sep 17 00:00:00 2001 From: SJost Date: Tue, 31 Jul 2018 15:35:35 +0200 Subject: [PATCH] Courselist for all courses --- messages/de.msg | 2 ++ src/Foundation.hs | 7 ++-- src/Handler/Course.hs | 82 ++++++++++++++++++++++++++++++++++++++++--- src/Handler/Sheet.hs | 13 ++++--- 4 files changed, 92 insertions(+), 12 deletions(-) diff --git a/messages/de.msg b/messages/de.msg index f9d9408a1..92a228190 100644 --- a/messages/de.msg +++ b/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 diff --git a/src/Foundation.hs b/src/Foundation.hs index b8f8fe169..131ed25bd 100644 --- a/src/Foundation.hs +++ b/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) diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 38cfbe239..201400194 100644 --- a/src/Handler/Course.hs +++ b/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 -getCourseListR = redirect TermCurrentR +type CourseTableData = DBRow (Entity Course, Int64) + +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 diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 150efc3d3..8319760f2 100644 --- a/src/Handler/Sheet.hs +++ b/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