From aec528d94c2ffc678fa9bd018e030c7f286eba76 Mon Sep 17 00:00:00 2001 From: SJost Date: Tue, 31 Jul 2018 14:08:59 +0200 Subject: [PATCH 1/4] =?UTF-8?q?=C3=9Cbersicht=20=C3=9Cbunbgsbl=C3=A4tter?= =?UTF-8?q?=20enth=C3=A4lt=20links=20f=C3=BCr=20Korrektur=20und=20Rating?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- ChangeLog.md | 5 ++++ messages/de.msg | 3 +- src/Handler/Corrections.hs | 39 ++++++++++++++++++------- src/Handler/Sheet.hs | 52 +++++++++++++++++++++++---------- templates/widgets/rating.hamlet | 16 ++++++++++ 5 files changed, 88 insertions(+), 27 deletions(-) create mode 100644 templates/widgets/rating.hamlet diff --git a/ChangeLog.md b/ChangeLog.md index fbe1b5009..2ffc74b71 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,4 +1,9 @@ + * Version 31.07.2018 + + Viele Verbesserung zur Anzeige von Korrekturen + * Version 10.07.2018 + Bugfixes, wählbares Format für Datum * Version 04.07.2018 diff --git a/messages/de.msg b/messages/de.msg index 8b271d82e..f9d9408a1 100644 --- a/messages/de.msg +++ b/messages/de.msg @@ -190,6 +190,7 @@ NotPassed: Nicht bestanden RatingTime: Korrigiert RatingComment: Kommentar SubmissionUsers: Studenten +Rating: Korrektur RatingPoints: Punkte RatingFiles: Korrigierte Dateien @@ -227,4 +228,4 @@ EditedBy name@Text time@Text: Durch #{name} um #{time} LastEdit: Letzte Änderung SubmissionFilesIgnored: Es wurden Dateien in der hochgeladenen Abgabe ignoriert: -SubmissionDoesNotExist smid@CryptoFileNameSubmission: Es existiert keine Abgabe mit Nummer #{toPathPiece smid}. \ No newline at end of file +SubmissionDoesNotExist smid@CryptoFileNameSubmission: Es existiert keine Abgabe mit Nummer #{toPathPiece smid}. diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index 3d2a61116..c2792c48d 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -85,19 +85,18 @@ colTerm = sortable (Just "term") (i18nCell MsgTerm) colCourse :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) colCourse = sortable (Just "course") (i18nCell MsgCourse) - $ \DBRow{ dbrOutput=(_, _, course, _, _) } -> cell $ + $ \DBRow{ dbrOutput=(_, _, course, _, _) } -> let tid = course ^. _3 csh = course ^. _2 - in [whamlet|#{display csh}|] + in anchorCell (CourseR tid csh CShowR) [whamlet|#{display csh}|] colSheet :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) colSheet = sortable (Just "sheet") (i18nCell MsgSheet) - $ \DBRow{ dbrOutput=(_, sheet, course, _, _) } -> cell $ - let tid = course ^. _3 - csh = course ^. _2 - shn = sheetName $ entityVal sheet - in [whamlet|#{display shn}|] - -- textCell $ sheetName $ entityVal sheet + $ \DBRow{ dbrOutput=(_, sheet, course, _, _) } -> + let tid = course ^. _3 + csh = course ^. _2 + shn = sheetName $ entityVal sheet + in anchorCell (CSheetR tid csh shn SShowR) [whamlet|#{display shn}|] colCorrector :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) colCorrector = sortable (Just "corrector") (i18nCell MsgCorrector) $ \case @@ -106,12 +105,15 @@ colCorrector = sortable (Just "corrector") (i18nCell MsgCorrector) $ \case colSubmissionLink :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) colSubmissionLink = sortable Nothing (i18nCell MsgSubmission) - $ \DBRow{ dbrOutput=(submission, sheet, course, _, _) } -> cell $ do + $ \DBRow{ dbrOutput=(submission, sheet, course, _, _) } -> let tid = course ^. _3 csh = course ^. _2 shn = sheetName $ entityVal sheet - cid <- encrypt (entityKey submission :: SubmissionId) - [whamlet|#{display cid}|] + mkCid = encrypt (entityKey submission :: SubmissionId) -- TODO: executed twice + mkRoute = do + cid <- mkCid + return $ CSubmissionR tid csh shn cid SubShowR + in anchorCellM mkRoute (mkCid >>= \cid -> [whamlet|#{display cid}|]) colSelect :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult CorrectionTableData CryptoFileNameSubmission Bool))) colSelect = dbSelect id $ \DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> encrypt subId @@ -121,6 +123,15 @@ colSubmittors = sortable Nothing (i18nCell MsgSubmissionUsers) $ \DBRow{ dbrOutp cell = listCell (Map.toList users) $ \(userId, User{..}) -> anchorCellM (AdminUserR <$> encrypt userId) (toWidget userDisplayName) in cell & cellAttrs <>~ [("class", "list--inline list--comma-separated")] +colRating :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) +colRating = sortable (Just "rating") (i18nCell MsgRating) $ \DBRow{ dbrOutput=(Entity subId Submission{..}, Entity _ Sheet{..}, course, _, _) } -> + let tid = course ^. _3 + csh = course ^. _2 + -- shn = sheetName + mkRoute = do + cid <- encrypt subId + return $ CSubmissionR tid csh sheetName cid CorrectionR + in anchorCellM mkRoute $(widgetFile "widgets/rating") type CorrectionTableExpr = (E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity Submission)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User)) @@ -165,6 +176,9 @@ makeCorrectionsTable whereClause colChoices psValidator = do , ( "corrector" , SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` corrector) -> corrector E.?. UserDisplayName ) + , ( "rating" + , SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _) -> submission E.^. SubmissionRatingPoints + ) ] , dbtFilter = [ ( "term" , FilterColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _ :: CorrectionTableExpr) tids -> if @@ -317,6 +331,7 @@ postCorrectionsR = do , colCourse , colSheet , colSubmissionLink + , colRating ] -- Continue here psValidator = def & restrictFilter (\name _ -> name /= "corrector") -- We need to be careful to restrict allowed sorting/filter to not expose sensitive information @@ -337,6 +352,7 @@ postCCorrectionsR tid csh = do , colCorrector , colSubmittors , colSubmissionLink + , colRating ] -- Continue here psValidator = def correctionsR whereClause colonnade psValidator $ Map.fromList @@ -355,6 +371,7 @@ postSSubsR tid csh shn = do , colCorrector , colSubmittors , colSubmissionLink + , colRating ] psValidator = def correctionsR whereClause colonnade psValidator $ Map.fromList diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 64cc2a6b2..150efc3d3 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -156,49 +156,71 @@ makeSheetForm msId template = identForm FIDsheet $ \html -> do getSheetListR :: TermId -> CourseShorthand -> Handler Html getSheetListR tid csh = do + muid <- maybeAuthId Entity cid _ <- runDB . getBy404 $ CourseTermShort tid csh let - sheetData :: E.SqlExpr (E.Entity Sheet) -> E.SqlQuery (E.SqlExpr (Entity Sheet), E.SqlExpr (E.Value (Maybe UTCTime))) - sheetData sheet = do + sheetData :: E.SqlExpr (Entity Sheet) `E.LeftOuterJoin` (E.SqlExpr (Maybe (Entity Submission)) `E.InnerJoin` (E.SqlExpr (Maybe (Entity SubmissionUser)))) -> E.SqlQuery (E.SqlExpr (Entity Sheet), E.SqlExpr (E.Value (Maybe UTCTime)),E.SqlExpr (Maybe (Entity Submission))) + sheetData (sheet `E.LeftOuterJoin` (submission `E.InnerJoin` submissionUser)) = do + E.on $ submission E.?. SubmissionId E.==. submissionUser E.?. SubmissionUserSubmission + E.on $ (E.just $ sheet E.^. SheetId) E.==. submission E.?. SubmissionSheet + E.&&. submissionUser E.?. SubmissionUserUser E.==. E.val muid let sheetEdit = E.sub_select . E.from $ \sheetEdit -> do E.where_ $ sheetEdit E.^. SheetEditSheet E.==. sheet E.^. SheetId return . E.max_ $ sheetEdit E.^. SheetEditTime E.where_ $ sheet E.^. SheetCourse E.==. E.val cid - return (sheet, sheetEdit) + return (sheet, sheetEdit, submission) sheetCol = widgetColonnade . mconcat $ [ sortable (Just "name") (i18nCell MsgSheet) - $ \(Entity _ Sheet{..}, _) -> anchorCell (CSheetR tid csh sheetName SShowR) (toWidget sheetName) + $ \(Entity _ Sheet{..}, _, _) -> anchorCell (CSheetR tid csh sheetName SShowR) (toWidget sheetName) , sortable (Just "last-edit") (i18nCell MsgLastEdit) - $ \(_, E.Value mEditTime) -> case mEditTime of - Just editTime -> cell $ formatTime SelFormatDateTime (editTime :: UTCTime) >>= toWidget - Nothing -> mempty + $ \(_, E.Value mEditTime, _) -> case mEditTime of + Just editTime -> cell $ formatTime SelFormatDateTime (editTime :: UTCTime) >>= toWidget + Nothing -> mempty , sortable (Just "submission-since") (i18nCell MsgSheetActiveFrom) - $ \(Entity _ Sheet{..}, _) -> cell $ formatTime SelFormatDateTime sheetActiveFrom >>= toWidget + $ \(Entity _ Sheet{..}, _, _) -> cell $ formatTime SelFormatDateTime sheetActiveFrom >>= toWidget , sortable (Just "submission-until") (i18nCell MsgSheetActiveTo) - $ \(Entity _ Sheet{..}, _) -> cell $ formatTime SelFormatDateTime sheetActiveTo >>= toWidget + $ \(Entity _ Sheet{..}, _, _) -> cell $ formatTime SelFormatDateTime sheetActiveTo >>= toWidget , sortable Nothing (i18nCell MsgSheetType) - $ \(Entity _ Sheet{..}, _) -> textCell $ display sheetType + $ \(Entity _ Sheet{..}, _, _) -> textCell $ display sheetType + , sortable (Just "submitted") (i18nCell MsgSubmission) + $ \(Entity _ Sheet{..}, _, mbSub) -> case mbSub of + Nothing -> mempty + (Just (Entity sid Submission{..})) -> + let mkCid = encrypt sid -- TODO: executed twice + mkRoute = do + cid <- mkCid + return $ CSubmissionR tid csh sheetName cid SubShowR + in anchorCellM mkRoute (mkCid >>= \cid -> [whamlet|#{display cid}|]) + , sortable (Just "rating") (i18nCell MsgRating) + $ \(Entity _ Sheet{..}, _, mbSub) -> case mbSub of + Nothing -> mempty + (Just (Entity sid Submission{..})) -> + let mkCid = encrypt sid + mkRoute = do + cid <- mkCid + return $ CSubmissionR tid csh sheetName cid CorrectionR + in anchorCellM mkRoute $(widgetFile "widgets/rating") ] psValidator = def & defaultSorting [("submission-since", SortAsc)] table <- dbTable psValidator $ DBTable { dbtSQLQuery = sheetData , dbtColonnade = sheetCol - , dbtProj = \DBRow{ dbrOutput = dbrOutput@(Entity _ Sheet{..}, _) } + , dbtProj = \DBRow{ dbrOutput = dbrOutput@(Entity _ Sheet{..}, _, _) } -> dbrOutput <$ guardM (lift $ (== Authorized) <$> evalAccessDB (CSheetR tid csh sheetName SShowR) False) , dbtSorting = Map.fromList [ ( "name" - , SortColumn $ \sheet -> sheet E.^. SheetName + , SortColumn $ \(sheet `E.LeftOuterJoin` submission) -> sheet E.^. SheetName ) , ( "last-edit" - , SortColumn $ \sheet -> E.sub_select . E.from $ \sheetEdit -> E.distinctOnOrderBy [E.desc $ sheetEdit E.?. SheetEditTime] $ do + , SortColumn $ \(sheet `E.LeftOuterJoin` submission) -> E.sub_select . E.from $ \sheetEdit -> E.distinctOnOrderBy [E.desc $ sheetEdit E.?. SheetEditTime] $ do return $ sheetEdit E.?. SheetEditTime ) , ( "submission-since" - , SortColumn $ \sheet -> sheet E.^. SheetActiveFrom + , SortColumn $ \(sheet `E.LeftOuterJoin` submission) -> sheet E.^. SheetActiveFrom ) , ( "submission-until" - , SortColumn $ \sheet -> sheet E.^. SheetActiveTo + , SortColumn $ \(sheet `E.LeftOuterJoin` submission) -> sheet E.^. SheetActiveTo ) ] , dbtFilter = Map.fromList diff --git a/templates/widgets/rating.hamlet b/templates/widgets/rating.hamlet new file mode 100644 index 000000000..f1c321bfd --- /dev/null +++ b/templates/widgets/rating.hamlet @@ -0,0 +1,16 @@ +$# Display Rating, expects +$# submissionRatingPoints :: Maybe points + +$maybe points <- submissionRatingPoints + $case sheetType + $of Bonus{..} + _{MsgAchievedOf points maxPoints} + $of Normal{..} + _{MsgAchievedOf points maxPoints} + $of Pass{..} + $if points >= passingPoints + _{MsgPassed} + $else + _{MsgNotPassed} + $of NotGraded + #{show tickmark} From e9b504473c5ae90f948df71c474cf5a6bf7cb334 Mon Sep 17 00:00:00 2001 From: SJost Date: Tue, 31 Jul 2018 15:35:35 +0200 Subject: [PATCH 2/4] 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 From 118192c1685bdf1deb5e74fb82eb9d61090502a3 Mon Sep 17 00:00:00 2001 From: SJost Date: Tue, 31 Jul 2018 16:42:34 +0200 Subject: [PATCH 3/4] Kursliste zeigen Anmeldestatus --- ChangeLog.md | 2 + messages/de.msg | 1 + src/Handler/Course.hs | 132 ++++++++++++++------------ src/Handler/Utils/Table/Pagination.hs | 6 ++ 4 files changed, 78 insertions(+), 63 deletions(-) diff --git a/ChangeLog.md b/ChangeLog.md index 2ffc74b71..240b51546 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -2,6 +2,8 @@ Viele Verbesserung zur Anzeige von Korrekturen + Kursliste über alle Semester hinweg (Top-Level-Navigation "Kurse"), wird in Zukunft Filter/Suchfunktion erhalten + * Version 10.07.2018 Bugfixes, wählbares Format für Datum diff --git a/messages/de.msg b/messages/de.msg index 92a228190..ae6d17cb8 100644 --- a/messages/de.msg +++ b/messages/de.msg @@ -5,6 +5,7 @@ BtnRegister: Anmelden BtnDeregister: Abmelden BtnHijack: Sitzung übernehmen +Registered: Angemeldet RegisterFrom: Anmeldungen von RegisterTo: Anmeldungen bis DeRegUntil: Abmeldungen bis diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 201400194..3b95e77a1 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -34,45 +34,81 @@ import qualified Database.Esqueleto as E import qualified Data.UUID.Cryptographic as UUID -type CourseTableData = DBRow (Entity Course, Int64) +type CourseTableData = DBRow (Entity Course, Int64, Bool) colCourse :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a) colCourse = sortable (Just "course") (i18nCell MsgCourse) - $ \DBRow{ dbrOutput=(Entity cid Course{..}, _) } -> + $ \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{..}, _) } -> + $ \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{..}, _) } -> + $ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _) } -> anchorCell (TermCourseListR courseTerm) [whamlet|#{display courseTerm}|] +colRegFrom :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a) +colRegFrom = sortable (Just "register-from") (i18nCell MsgRegisterFrom) + $ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _) } -> + cell $ traverse (formatTime SelFormatDateTime) courseRegisterFrom >>= maybe mempty toWidget + +colRegTo :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a) +colRegTo = sortable (Just "register-to") (i18nCell MsgRegisterTo) + $ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _) } -> + cell $ traverse (formatTime SelFormatDateTime) courseRegisterTo >>= maybe mempty toWidget + +colParticipants :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a) +colParticipants = sortable (Just "participants") (i18nCell MsgCourseMembers) + $ \DBRow{ dbrOutput=(Entity cid Course{..}, currentParticipants, _) } -> textCell $ case courseCapacity of + Nothing -> MsgCourseMembersCount currentParticipants + Just max -> MsgCourseMembersCountLimited currentParticipants max + +colRegistered :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a) +colRegistered = sortable (Just "registered") (i18nCell MsgRegistered) + $ \DBRow{ dbrOutput=(Entity cid Course{..}, _, registered) } -> tickmarkCell registered + type CourseTableExpr = E.SqlExpr (Entity Course) +course2Participants :: CourseTableExpr -> E.SqlExpr (E.Value Int64) +course2Participants 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)) + +course2Registered :: Maybe UserId -> CourseTableExpr -> E.SqlExpr (E.Value Bool) +course2Registered muid course = E.exists . E.from $ \courseParticipant -> do + E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. course E.^. CourseId + E.&&. E.just (courseParticipant E.^. CourseParticipantUser) E.==. E.val muid + 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 + muid <- maybeAuthId 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) + let participants = course2Participants course + let registered = course2Registered muid course + E.where_ $ whereClause (course, participants, registered) + return (course, participants, registered) dbtProj :: DBRow _ -> MaybeT (ReaderT SqlBackend (HandlerT UniWorX IO)) CourseTableData - dbtProj = traverse $ \(course, E.Value participants) -> return (course, participants) + dbtProj = traverse $ \(course, E.Value participants, E.Value registered) -> return (course, participants, registered) 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) + [ ( "course", SortColumn $ \course -> course E.^. CourseName) + , ( "cshort", SortColumn $ \course -> course E.^. CourseShorthand) + , ( "term" , SortColumn $ \course -> course E.^. CourseTerm) + , ( "register-from", SortColumn $ \course -> course E.^. CourseRegisterFrom) + , ( "register-to", SortColumn $ \course -> course E.^. CourseRegisterTo) + , ( "participants", SortColumn $ course2Participants + ) + , ( "registered", SortColumn $ course2Registered muid + ) ] , dbtFilter = [ ( "course", FilterColumn $ \(course :: CourseTableExpr) criterias -> if @@ -93,18 +129,22 @@ makeCourseTable whereClause colChoices psValidator = do } getCourseListR :: Handler Html -getCourseListR = do -- TODO: KurseList aller Kurse mit Suchfunktion! +getCourseListR = do -- TODO: Suchfunktion für Kurse und Kürzel!!! + muid <- maybeAuthId let colonnade = widgetColonnade $ mconcat [ colCourse , colCShort , colTerm + , maybe mempty (const colRegistered) muid ] - validator = def whereClause = const $ E.val True - ctable <- makeCourseTable whereClause colonnade validator + validator = def + & defaultSorting [("course", SortAsc), ("term", SortDesc)] + coursesTable <- makeCourseTable whereClause colonnade validator defaultLayout $ do setTitleI MsgCourseListTitle - ctable + [whamlet|TODO: Such-/Filterfunktion hier einbauen|] -- TODO + $(widgetFile "courses") getTermCurrentR :: Handler Html getTermCurrentR = do @@ -117,53 +157,19 @@ getTermCurrentR = do getTermCourseListR :: TermId -> Handler Html 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{..}, _) -> cell $ traverse (formatTime SelFormatDateTime) courseRegisterFrom >>= maybe mempty toWidget - , sortable (Just "register-to") (textCell MsgRegisterTo) $ \(Entity _ Course{..}, _) -> cell $ traverse (formatTime SelFormatDateTime) courseRegisterTo >>= maybe mempty toWidget - , sortable (Just "members") (textCell MsgCourseMembers) $ \(Entity _ Course{..}, E.Value num) -> textCell $ case courseCapacity of - Nothing -> MsgCourseMembersCount num - Just max -> MsgCourseMembersCountLimited num max + muid <- maybeAuthId + let colonnade = widgetColonnade $ mconcat + [ dbRow + , colCShort + , colRegFrom + , colRegTo + , colParticipants + , maybe mempty (const colRegistered) muid ] - , dbtProj = return . dbrOutput - , dbtSorting = Map.fromList - [ ( "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 = mempty - , dbtStyle = def - , dbtIdent = "courses" :: Text - } - + whereClause = \(course, _, _) -> course E.^. CourseTerm E.==. E.val tid + validator = def + & defaultSorting [("cshort", SortAsc)] + coursesTable <- makeCourseTable whereClause colonnade validator defaultLayout $ do setTitleI . MsgTermCourseListTitle $ tid $(widgetFile "courses") diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index a7bda4a73..cc2b06fe6 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -34,6 +34,7 @@ module Handler.Utils.Table.Pagination , widgetColonnade, formColonnade, dbColonnade , cell, textCell, stringCell, i18nCell , anchorCell, anchorCell', anchorCellM + , tickmarkCell , listCell , formCell, DBFormResult, getDBFormResult , dbRow, dbSelect @@ -472,6 +473,11 @@ stringCell = textCell i18nCell = textCell textCell msg = cell [whamlet|_{msg}|] +tickmarkCell :: (IsDBTable m a) => Bool -> DBCell m a +tickmarkCell True = textCell (tickmark :: Text) +tickmarkCell False = mempty + + anchorCell :: IsDBTable m a => Route UniWorX -> Widget -> DBCell m a anchorCell = anchorCellM . return From fdeec42d366d761042bc065ff16a2fa79c3f54fc Mon Sep 17 00:00:00 2001 From: SJost Date: Tue, 31 Jul 2018 16:48:39 +0200 Subject: [PATCH 4/4] Bugfix overloaded Lists in Course --- src/Handler/Course.hs | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 3b95e77a1..080e444ec 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -1,7 +1,6 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE RecordWildCards, NamedFieldPuns, TupleSections #-} @@ -99,7 +98,7 @@ makeCourseTable whereClause colChoices psValidator = do { dbtSQLQuery , dbtColonnade = colChoices , dbtProj - , dbtSorting = + , dbtSorting = Map.fromList -- OverloadedLists does not work with the templates here [ ( "course", SortColumn $ \course -> course E.^. CourseName) , ( "cshort", SortColumn $ \course -> course E.^. CourseShorthand) , ( "term" , SortColumn $ \course -> course E.^. CourseTerm) @@ -110,7 +109,7 @@ makeCourseTable whereClause colChoices psValidator = do , ( "registered", SortColumn $ course2Registered muid ) ] - , dbtFilter = + , dbtFilter = Map.fromList -- OverloadedLists does not work with the templates here [ ( "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)