From 4d3f4d56b5a1d5efb097c4a18b6242983b042bfd Mon Sep 17 00:00:00 2001 From: SJost Date: Thu, 24 Jan 2019 17:09:55 +0100 Subject: [PATCH 1/5] Convenience Current Sheet --- src/Foundation.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Foundation.hs b/src/Foundation.hs index 6d226e578..179789442 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -1248,7 +1248,7 @@ pageActions (CourseR tid ssh csh CShowR) = E.&&. course E.^. CourseTerm E.==. E.val tid E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseShorthand E.==. E.val csh - E.orderBy [E.asc $ sheet E.^. SheetActiveFrom] + E.orderBy [E.asc $ sheet E.^. SheetActiveTo] E.limit 1 return $ sheet E.^. SheetName case sheets of From e0fe371971815cf447fd81883832ca719db45946 Mon Sep 17 00:00:00 2001 From: SJost Date: Thu, 24 Jan 2019 18:05:21 +0100 Subject: [PATCH 2/5] Statistics for SheetList not working anymore --- src/Handler/Sheet.hs | 27 +++++++++++++-------------- 1 file changed, 13 insertions(+), 14 deletions(-) diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 9ac923421..7baf5243f 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -221,11 +221,13 @@ getSheetListR tid ssh csh = do $ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, mbSub)} -> case mbSub of Nothing -> mempty (Just (Entity sid Submission{..})) -> - let mkCid = encrypt sid + let _stats = sheetTypeSum sheetType submissionRatingPoints -- for statistics over all shown rows + mkCid = encrypt sid mkRoute = do cid' <- mkCid return $ CSubmissionR tid ssh csh sheetName cid' CorrectionR in anchorCellM mkRoute $(widgetFile "widgets/rating") + , sortable Nothing -- (Just "percent") (i18nCell MsgRatingPercent) $ \DBRow{dbrOutput=(Entity _ Sheet{sheetType=sType}, _, mbSub)} -> case mbSub of @@ -242,8 +244,7 @@ getSheetListR tid ssh csh = do psValidator = def & defaultSorting [SortDescBy "submission-since"] - (table,raw_statistics) <- runDB $ liftA2 (,) - (dbTableWidget' psValidator DBTable + (raw_statistics,table) <- runDB $ dbTableWidget psValidator DBTable { dbtColonnade = sheetCol , dbtSQLQuery = \dt@(sheet `E.LeftOuterJoin` (submission `E.InnerJoin` _submissionUser)) -> sheetData dt *> return (sheet, lastSheetEdit sheet, submission) @@ -282,18 +283,16 @@ getSheetListR tid ssh csh = do , dbtParams = def , dbtIdent = "sheets" :: Text } - ) ( - -- Collect summary over all Sheets, not just the ones shown due to pagination: - do - rows <- E.select $ E.from $ \dt@(sheet `E.LeftOuterJoin` (submission `E.InnerJoin` _submissionUser)) -> - sheetData dt *> return (sheet E.^. SheetName, sheet E.^. SheetType, submission E.?. SubmissionRatingPoints) - flip filterM rows (\(E.Value sheetName, _, _) -> sheetFilter sheetName) - ) + -- ) ( -- !!!DEPRECTAED!!! Summary only over shown rows !!! + -- -- Collect summary over all Sheets, not just the ones shown due to pagination: + -- do + -- rows <- E.select $ E.from $ \dt@(sheet `E.LeftOuterJoin` (submission `E.InnerJoin` _submissionUser)) -> + -- sheetData dt *> return (sheet E.^. SheetName, sheet E.^. SheetType, submission E.?. SubmissionRatingPoints) + -- flip filterM rows (\(E.Value sheetName, _, _) -> sheetFilter sheetName) + -- ) - let statistics = - gradeSummaryWidget MsgSheetGradingSummaryTitle $ - foldMap (\(_, E.Value sheetType, E.Value mbPts) -> sheetTypeSum sheetType (join mbPts)) - raw_statistics + let statistics = gradeSummaryWidget MsgSheetGradingSummaryTitle raw_statistics -- only over shown rows + -- foldMap (\(_, E.Value sheetType, E.Value mbPts) -> sheetTypeSum sheetType (join mbPts)) defaultLayout $ do $(widgetFile "sheetList") From c0605024c963079fa3ef89499b20337afd395ee4 Mon Sep 17 00:00:00 2001 From: SJost Date: Thu, 24 Jan 2019 18:41:58 +0100 Subject: [PATCH 3/5] Handler.Utils.Table.cellTell added, but does not work as intended. --- src/Handler/Sheet.hs | 4 ++-- src/Handler/Utils/Table/Cells.hs | 9 +++++++++ 2 files changed, 11 insertions(+), 2 deletions(-) diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 7baf5243f..abf2d9a35 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -221,12 +221,12 @@ getSheetListR tid ssh csh = do $ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, mbSub)} -> case mbSub of Nothing -> mempty (Just (Entity sid Submission{..})) -> - let _stats = sheetTypeSum sheetType submissionRatingPoints -- for statistics over all shown rows + let stats = sheetTypeSum sheetType submissionRatingPoints -- for statistics over all shown rows mkCid = encrypt sid mkRoute = do cid' <- mkCid return $ CSubmissionR tid ssh csh sheetName cid' CorrectionR - in anchorCellM mkRoute $(widgetFile "widgets/rating") + in cellTell' stats $ anchorCellM mkRoute $(widgetFile "widgets/rating") , sortable Nothing -- (Just "percent") (i18nCell MsgRatingPercent) diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index 85d8571f7..a58bafff7 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -14,6 +14,15 @@ type CourseLink = (TermId, SchoolId, CourseShorthand) -- TODO: Refactor with Wit -------------------- -- Special cells +cellTell :: (Monoid a, IsDBTable m a) => a -> DBCell m a -> DBCell m a +cellTell x c = c & cellContents %~ (tell x *>) + +cellTell' :: Monoid w => w -> DBCell (HandlerT UniWorX IO) w -> DBCell (HandlerT UniWorX IO) w +cellTell' x c = c { wgtCellContents = tell x >> oldContent } + where + oldContent = wgtCellContents c + + indicatorCell :: IsDBTable m Any => DBCell m Any -- For dbTables that return a Bool to indicate content indicatorCell = mempty & cellContents %~ (tell (Any True) *>) From 371a9e4673abb1609990f17f7f56e985da99a461 Mon Sep 17 00:00:00 2001 From: SJost Date: Thu, 24 Jan 2019 22:21:10 +0100 Subject: [PATCH 4/5] refactored course navigation --- src/Foundation.hs | 97 ++++++++++++++++++++++------------------------- 1 file changed, 45 insertions(+), 52 deletions(-) diff --git a/src/Foundation.hs b/src/Foundation.hs index 179789442..f60ca5e3b 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -1233,6 +1233,51 @@ pageActions (CourseListR) = } ] pageActions (CourseR tid ssh csh CShowR) = + [ MenuItem + { menuItemType = PageActionPrime + , menuItemLabel = MsgMenuSheetList + , menuItemIcon = Nothing + , menuItemRoute = SomeRoute $ CourseR tid ssh csh SheetListR + , menuItemModal = False + , menuItemAccessCallback' = do --TODO always show for lecturer + let sheetRouteAccess shn = (== Authorized) <$> evalAccess (CSheetR tid ssh csh shn SShowR) False + muid <- maybeAuthId + (sheets,lecturer) <- runDB $ do + cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh + sheets <- map (sheetName.entityVal) <$> selectList [SheetCourse ==. cid] [Desc SheetActiveFrom] + lecturer <- case muid of + Nothing -> return False + (Just uid) -> existsBy $ UniqueLecturer uid cid + return (sheets,lecturer) + or2M (return lecturer) $ anyM sheets sheetRouteAccess + } + ] ++ pageActions (CourseR tid ssh csh SheetListR) ++ + [ MenuItem + { menuItemType = PageActionSecondary + , menuItemLabel = MsgMenuCourseEdit + , menuItemIcon = Nothing + , menuItemRoute = SomeRoute $ CourseR tid ssh csh CEditR + , menuItemModal = False + , menuItemAccessCallback' = return True + } + , MenuItem + { menuItemType = PageActionSecondary + , menuItemLabel = MsgMenuCourseNewTemplate + , menuItemIcon = Nothing + , menuItemRoute = SomeRoute (CourseNewR, [("tid", toPathPiece tid), ("ssh", toPathPiece ssh), ("csh", toPathPiece csh)]) + , menuItemModal = False + , menuItemAccessCallback' = return True + } + , MenuItem + { menuItemType = PageActionSecondary + , menuItemLabel = MsgMenuCourseDelete + , menuItemIcon = Nothing + , menuItemRoute = SomeRoute $ CourseR tid ssh csh CDeleteR + , menuItemModal = False + , menuItemAccessCallback' = return True + } + ] +pageActions (CourseR tid ssh csh SheetListR) = [ MenuItem { menuItemType = PageActionPrime , menuItemLabel = MsgMenuSheetCurrent @@ -1263,24 +1308,6 @@ pageActions (CourseR tid ssh csh CShowR) = , menuItemModal = False , menuItemAccessCallback' = (== Authorized) <$> evalAccessCorrector tid ssh csh } - , MenuItem - { menuItemType = PageActionPrime - , menuItemLabel = MsgMenuSheetList - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute $ CourseR tid ssh csh SheetListR - , menuItemModal = False - , menuItemAccessCallback' = do --TODO always show for lecturer - let sheetRouteAccess shn = (== Authorized) <$> evalAccess (CSheetR tid ssh csh shn SShowR) False - muid <- maybeAuthId - (sheets,lecturer) <- runDB $ do - cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh - sheets <- map (sheetName.entityVal) <$> selectList [SheetCourse ==. cid] [Desc SheetActiveFrom] - lecturer <- case muid of - Nothing -> return False - (Just uid) -> existsBy $ UniqueLecturer uid cid - return (sheets,lecturer) - or2M (return lecturer) $ anyM sheets sheetRouteAccess - } , MenuItem { menuItemType = PageActionPrime , menuItemLabel = MsgMenuSubmissions @@ -1317,40 +1344,6 @@ pageActions (CourseR tid ssh csh CShowR) = , menuItemModal = False , menuItemAccessCallback' = return True } - , MenuItem - { menuItemType = PageActionSecondary - , menuItemLabel = MsgMenuCourseEdit - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute $ CourseR tid ssh csh CEditR - , menuItemModal = False - , menuItemAccessCallback' = return True - } - , MenuItem - { menuItemType = PageActionSecondary - , menuItemLabel = MsgMenuCourseNewTemplate - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute (CourseNewR, [("tid", toPathPiece tid), ("ssh", toPathPiece ssh), ("csh", toPathPiece csh)]) - , menuItemModal = False - , menuItemAccessCallback' = return True - } - , MenuItem - { menuItemType = PageActionSecondary - , menuItemLabel = MsgMenuCourseDelete - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute $ CourseR tid ssh csh CDeleteR - , menuItemModal = False - , menuItemAccessCallback' = return True - } - ] -pageActions (CourseR tid ssh csh SheetListR) = - [ MenuItem - { menuItemType = PageActionPrime - , menuItemLabel = MsgMenuSheetNew - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute $ CourseR tid ssh csh SheetNewR - , menuItemModal = False - , menuItemAccessCallback' = return True - } ] pageActions (CSheetR tid ssh csh shn SShowR) = [ MenuItem From 30614511a5eae39c99f998e1b9c491a36f95abf3 Mon Sep 17 00:00:00 2001 From: SJost Date: Fri, 25 Jan 2019 10:40:18 +0100 Subject: [PATCH 5/5] Fixes #277 --- src/Foundation.hs | 33 ++++++++++++++++++--------------- 1 file changed, 18 insertions(+), 15 deletions(-) diff --git a/src/Foundation.hs b/src/Foundation.hs index f60ca5e3b..08aedb126 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -1326,15 +1326,18 @@ pageActions (CourseR tid ssh csh SheetListR) = ]) , menuItemModal = False , menuItemAccessCallback' = do - uid <- requireAuthId - [E.Value ok] <- runDB . E.select . return . E.exists . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` submission) -> do - E.on $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId - E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId - E.where_ $ submission E.^. SubmissionRatingBy E.==. E.just (E.val uid) - E.&&. course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseSchool E.==. E.val ssh - E.&&. course E.^. CourseShorthand E.==. E.val csh - return ok + muid <- maybeAuthId + case muid of + Nothing -> return False + (Just uid) -> do + [E.Value ok] <- runDB . E.select . return . E.exists . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` submission) -> do + E.on $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId + E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId + E.where_ $ submission E.^. SubmissionRatingBy E.==. E.just (E.val uid) + E.&&. course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + return ok } , MenuItem { menuItemType = PageActionPrime @@ -1494,9 +1497,9 @@ pageActions (CorrectionsR) = , menuItemIcon = Nothing , menuItemRoute = SomeRoute CorrectionsCreateR , menuItemModal = False - , menuItemAccessCallback' = runDB $ do - uid <- liftHandlerT requireAuthId - [E.Value sheetCount] <- E.select . E.from $ \(course `E.InnerJoin` sheet) -> do + , menuItemAccessCallback' = runDB . maybeT (return False) $ do + uid <- MaybeT $ liftHandlerT maybeAuthId + [E.Value sheetCount] <- lift . E.select . E.from $ \(course `E.InnerJoin` sheet) -> do E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse let isCorrector' = E.exists . E.from $ \sheetCorrector -> E.where_ @@ -1534,9 +1537,9 @@ pageActions (CorrectionsGradeR) = , menuItemIcon = Nothing , menuItemRoute = SomeRoute CorrectionsCreateR , menuItemModal = False - , menuItemAccessCallback' = runDB $ do - uid <- liftHandlerT requireAuthId - [E.Value sheetCount] <- E.select . E.from $ \(course `E.InnerJoin` sheet) -> do + , menuItemAccessCallback' = runDB . maybeT (return False) $ do + uid <- MaybeT $ liftHandlerT maybeAuthId + [E.Value sheetCount] <- lift . E.select . E.from $ \(course `E.InnerJoin` sheet) -> do E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse let isCorrector' = E.exists . E.from $ \sheetCorrector -> E.where_