Merge branch 'master' of gitlab.cip.ifi.lmu.de:jost/UniWorX

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
+  ] ++ pageActions (CourseR tid ssh csh SheetListR) ++
-      { menuItemType = PageActionPrime
+  [ MenuItem
-      , 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
       { 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
+      , menuItemAccessCallback' = runDB . maybeT (return False) $ do
-          uid <- liftHandlerT requireAuthId
+          uid <- MaybeT $ liftHandlerT maybeAuthId
-          [E.Value sheetCount] <- E.select . E.from $ \(course `E.InnerJoin` sheet) -> do
+          [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
+      , menuItemAccessCallback' = runDB . maybeT (return False) $ do
-          uid <- liftHandlerT requireAuthId
+          uid <- MaybeT $ liftHandlerT maybeAuthId
-          [E.Value sheetCount] <- E.select . E.from $ \(course `E.InnerJoin` sheet) -> do
+          [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_

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 (,)
+  (raw_statistics,table) <- runDB $ dbTableWidget psValidator DBTable
-    (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
       }
-    ) (
+    -- ) ( -- !!!DEPRECTAED!!! Summary only over shown rows !!!
-      -- Collect summary over all Sheets, not just the ones shown due to pagination:
+    --   -- Collect summary over all Sheets, not just the ones shown due to pagination:
-      do
+    --   do
-        rows <- E.select $ E.from $ \dt@(sheet `E.LeftOuterJoin` (submission `E.InnerJoin` _submissionUser)) ->
+    --     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)
+    --       sheetData dt *> return (sheet E.^. SheetName, sheet E.^. SheetType, submission E.?. SubmissionRatingPoints)
-        flip filterM rows (\(E.Value sheetName, _, _) -> sheetFilter sheetName)
+    --     flip filterM rows (\(E.Value sheetName, _, _) -> sheetFilter sheetName)
-    )
+    -- )
 
-  let statistics =
+  let statistics = gradeSummaryWidget MsgSheetGradingSummaryTitle raw_statistics -- only over shown rows
-        gradeSummaryWidget MsgSheetGradingSummaryTitle $
+        -- foldMap (\(_, E.Value sheetType, E.Value mbPts) -> sheetTypeSum sheetType (join mbPts))
-        foldMap (\(_, E.Value sheetType, E.Value mbPts) -> sheetTypeSum sheetType (join mbPts))
-        raw_statistics
   defaultLayout $ do
     $(widgetFile "sheetList")
 

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