diff --git a/src/Foundation.hs b/src/Foundation.hs index 6d226e578..08aedb126 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -1234,36 +1234,6 @@ pageActions (CourseListR) = ] pageActions (CourseR tid ssh csh CShowR) = [ MenuItem - { menuItemType = PageActionPrime - , menuItemLabel = MsgMenuSheetCurrent - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute $ CourseR tid ssh csh SheetCurrentR - , menuItemModal = False - , menuItemAccessCallback' = do - now <- liftIO getCurrentTime - sheets <- runDB . E.select . E.from $ \(course `E.InnerJoin` sheet) -> do - E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId - E.where_ $ sheet E.^. SheetActiveTo E.>. E.val now - E.&&. sheet E.^. SheetActiveFrom E.<=. E.val now - 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.limit 1 - return $ sheet E.^. SheetName - case sheets of - (E.Value shn):_ -> (== Authorized) <$> isAuthorized (CSheetR tid ssh csh shn SShowR) False - _ -> return False - } - , MenuItem - { menuItemType = PageActionPrime - , menuItemLabel = MsgMenuSheetLastInactive - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute $ CourseR tid ssh csh SheetLastInactiveR - , menuItemModal = False - , menuItemAccessCallback' = (== Authorized) <$> evalAccessCorrector tid ssh csh - } - , MenuItem { menuItemType = PageActionPrime , menuItemLabel = MsgMenuSheetList , menuItemIcon = Nothing @@ -1281,43 +1251,8 @@ pageActions (CourseR tid ssh csh CShowR) = return (sheets,lecturer) or2M (return lecturer) $ anyM sheets sheetRouteAccess } - , MenuItem - { menuItemType = PageActionPrime - , menuItemLabel = MsgMenuSubmissions - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute $ CourseR tid ssh csh CCorrectionsR - , menuItemModal = False - , menuItemAccessCallback' = return True - } - , MenuItem - { menuItemType = PageActionPrime - , menuItemLabel = MsgMenuCorrectionsOwn - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute (CorrectionsR, [ ("corrections-term" , termToText $ unTermKey tid) - , ("corrections-school", CI.original $ unSchoolKey ssh) - , ("corrections-course", CI.original csh) - ]) - , 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 - } - , MenuItem - { menuItemType = PageActionPrime - , menuItemLabel = MsgMenuSheetNew - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute $ CourseR tid ssh csh SheetNewR - , menuItemModal = False - , menuItemAccessCallback' = return True - } - , MenuItem + ] ++ pageActions (CourseR tid ssh csh SheetListR) ++ + [ MenuItem { menuItemType = PageActionSecondary , menuItemLabel = MsgMenuCourseEdit , menuItemIcon = Nothing @@ -1344,6 +1279,67 @@ pageActions (CourseR tid ssh csh CShowR) = ] pageActions (CourseR tid ssh csh SheetListR) = [ MenuItem + { menuItemType = PageActionPrime + , menuItemLabel = MsgMenuSheetCurrent + , menuItemIcon = Nothing + , menuItemRoute = SomeRoute $ CourseR tid ssh csh SheetCurrentR + , menuItemModal = False + , menuItemAccessCallback' = do + now <- liftIO getCurrentTime + sheets <- runDB . E.select . E.from $ \(course `E.InnerJoin` sheet) -> do + E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId + E.where_ $ sheet E.^. SheetActiveTo E.>. E.val now + E.&&. sheet E.^. SheetActiveFrom E.<=. E.val now + 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.^. SheetActiveTo] + E.limit 1 + return $ sheet E.^. SheetName + case sheets of + (E.Value shn):_ -> (== Authorized) <$> isAuthorized (CSheetR tid ssh csh shn SShowR) False + _ -> return False + } + , MenuItem + { menuItemType = PageActionPrime + , menuItemLabel = MsgMenuSheetLastInactive + , menuItemIcon = Nothing + , menuItemRoute = SomeRoute $ CourseR tid ssh csh SheetLastInactiveR + , menuItemModal = False + , menuItemAccessCallback' = (== Authorized) <$> evalAccessCorrector tid ssh csh + } + , MenuItem + { menuItemType = PageActionPrime + , menuItemLabel = MsgMenuSubmissions + , menuItemIcon = Nothing + , menuItemRoute = SomeRoute $ CourseR tid ssh csh CCorrectionsR + , menuItemModal = False + , menuItemAccessCallback' = return True + } + , MenuItem + { menuItemType = PageActionPrime + , menuItemLabel = MsgMenuCorrectionsOwn + , menuItemIcon = Nothing + , menuItemRoute = SomeRoute (CorrectionsR, [ ("corrections-term" , termToText $ unTermKey tid) + , ("corrections-school", CI.original $ unSchoolKey ssh) + , ("corrections-course", CI.original csh) + ]) + , menuItemModal = False + , menuItemAccessCallback' = do + 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 , menuItemLabel = MsgMenuSheetNew , menuItemIcon = Nothing @@ -1501,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_ @@ -1541,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_ diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 9ac923421..abf2d9a35 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") + in cellTell' stats $ 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") diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index 7798a02ac..cc1e21a5a 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -15,6 +15,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 = writerCell . tell $ Any True