Merge branch 'master' of gitlab.cip.ifi.lmu.de:jost/UniWorX
This commit is contained in:
Gregor Kleen
commit
593ec541b8
@ -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_
|
||||
|
||||
@ -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")
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user