191 lines
10 KiB
Haskell
191 lines
10 KiB
Haskell
module Handler.Sheet.List
|
|
( getSheetListR
|
|
) where
|
|
|
|
import Import hiding (link)
|
|
|
|
import Utils.Sheet
|
|
import Handler.Utils
|
|
import Handler.Utils.SheetType
|
|
|
|
import qualified Database.Esqueleto.Legacy as E
|
|
import qualified Database.Esqueleto.Utils as E
|
|
|
|
import qualified Data.Map as Map
|
|
|
|
|
|
getSheetListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
|
getSheetListR tid ssh csh = do
|
|
muid <- maybeAuthId
|
|
now <- liftIO getCurrentTime
|
|
cid <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh
|
|
let
|
|
hasSFT :: (E.Value Bool, E.Value Bool, E.Value Bool, E.Value Bool) -> [SheetFileType]
|
|
hasSFT (E.Value hasExercise, E.Value hasHint, E.Value hasSolution, E.Value hasMarking)
|
|
= [ sft | sft <- universeF
|
|
, sft /= SheetExercise || hasExercise
|
|
, sft /= SheetHint || hasHint
|
|
, sft /= SheetSolution || hasSolution
|
|
, sft /= SheetMarking || hasMarking
|
|
]
|
|
lastSheetEdit sheet = E.subSelectMaybe . E.from $ \sheetEdit -> do
|
|
E.where_ $ sheetEdit E.^. SheetEditSheet E.==. sheet E.^. SheetId
|
|
return . E.max_ $ sheetEdit E.^. SheetEditTime
|
|
|
|
sheetData :: E.SqlExpr (Entity Sheet) `E.LeftOuterJoin` (E.SqlExpr (Maybe (Entity Submission)) `E.InnerJoin` E.SqlExpr (Maybe (Entity SubmissionUser))) -> E.SqlQuery ()
|
|
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
|
|
E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
|
|
|
|
querySubmission :: E.SqlExpr (Entity Sheet) `E.LeftOuterJoin` (E.SqlExpr (Maybe (Entity Submission)) `E.InnerJoin` E.SqlExpr (Maybe (Entity SubmissionUser))) -> E.SqlExpr (Maybe (Entity Submission))
|
|
querySubmission (_sheet `E.LeftOuterJoin` (submission `E.InnerJoin` _submissionUser)) = submission
|
|
|
|
sheetFilter :: SheetName -> DB Bool
|
|
sheetFilter sheetName = hasReadAccessTo $ CSheetR tid ssh csh sheetName SShowR
|
|
|
|
sheetCol = widgetColonnade . mconcat $
|
|
[ -- dbRow ,
|
|
sortable (Just "name") (i18nCell MsgTableSheet)
|
|
$ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _, _)} -> anchorCell (CSheetR tid ssh csh sheetName SShowR) sheetName
|
|
, sortable (Just "last-edit") (i18nCell MsgTableLastEdit)
|
|
$ \DBRow{dbrOutput=(_, E.Value mEditTime, _, _)} -> foldMap dateTimeCell mEditTime
|
|
, sortable (Just "visible-from") (i18nCell MsgSheetAccessibleSince)
|
|
$ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _, _)} -> foldMap (dateTimeCellVisible now) sheetVisibleFrom
|
|
, sortable (toNothing "downloads") (i18nCell MsgFiles)
|
|
$ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _, existFiles)} -> listCell
|
|
[ icnCell & addIconFixedWidth
|
|
| let existingSFTs = hasSFT existFiles
|
|
, sft <- [minBound..maxBound]
|
|
, let link = CSheetR tid ssh csh sheetName $ SZipR sft
|
|
, let icn = toWgt $ sheetFile2markup sft
|
|
, let icnCell = if sft `elem` existingSFTs
|
|
then linkEitherCell link (icn, [whamlet| |])
|
|
else spacerCell
|
|
] id & cellAttrs <>~ [("class","list--inline list--space-separated")]
|
|
, sortable (Just "submission-since") (i18nCell MsgSheetActiveFrom)
|
|
$ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _, _)} -> maybe mempty dateTimeCell sheetActiveFrom
|
|
, sortable (Just "submission-until") (i18nCell MsgSheetActiveTo)
|
|
$ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _, _)} -> maybe mempty dateTimeCell sheetActiveTo
|
|
, sortable Nothing (i18nCell MsgSheetSheetType) $ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _, _)} -> cell $ do
|
|
sheetTypeDesc <- liftHandler . runDB $ sheetTypeDescription sheetCourse sheetType
|
|
tr <- getTranslate
|
|
toWidget $ sheetTypeDesc tr
|
|
, sortable Nothing (i18nCell MsgTableSubmission)
|
|
$ \DBRow{dbrOutput=(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 ssh csh sheetName cid' SubShowR
|
|
in anchorCellM mkRoute (mkCid >>= \cid2 -> [whamlet|#{cid2}|])
|
|
, sortable (Just "rating") (i18nCell MsgTableRating)
|
|
$ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, mbSub,_)} ->
|
|
let stats = sheetTypeSum sheetType in -- for statistics over all shown rows
|
|
case mbSub of
|
|
Nothing -> cellTell mempty $ stats Nothing
|
|
(Just (Entity sid sub@Submission{..})) ->
|
|
let
|
|
mkRoute :: (MonadHandler m, HandlerSite m ~ UniWorX) => m (Route UniWorX)
|
|
mkRoute = liftHandler $ do
|
|
cid' <- encrypt sid
|
|
return $ CSubmissionR tid ssh csh sheetName cid' CorrectionR
|
|
acell = anchorCellM mkRoute $(widgetFile "widgets/rating/rating")
|
|
tellStats = tell $ stats submissionRatingPoints
|
|
in guardAuthCell ((, False) <$> mkRoute) $ acell & cellContents %~ (<* tellStats)
|
|
|
|
, sortable Nothing -- (Just "percent")
|
|
(i18nCell MsgRatingPercent)
|
|
$ \DBRow{dbrOutput=(Entity _ Sheet{sheetType=sType, sheetName}, _, mbSub,_)} -> case mbSub of
|
|
(Just (Entity sid Submission{submissionRatingPoints=Just sPoints})) ->
|
|
case preview (_grading . _maxPoints) sType of
|
|
Just maxPoints
|
|
| maxPoints /= 0 ->
|
|
let
|
|
mkRoute = liftHandler $ do
|
|
cid' <- encrypt sid
|
|
return $ CSubmissionR tid ssh csh sheetName cid' CorrectionR
|
|
in guardAuthCell ((, False) <$> mkRoute) . cell $ do
|
|
toWidget . toMessage $ textPercent sPoints maxPoints
|
|
_other -> mempty
|
|
_other -> mempty
|
|
]
|
|
|
|
psValidator = def
|
|
& defaultSorting [SortDescBy "submission-until", SortDescBy "submission-since"]
|
|
& forceFilter "may-access" (Any True)
|
|
|
|
(raw_statistics,table) <- runDB $ dbTableWidget psValidator DBTable
|
|
{ dbtColonnade = sheetCol
|
|
, dbtSQLQuery = \dt@(sheet `E.LeftOuterJoin` (submission `E.InnerJoin` _submissionUser)) -> do
|
|
sheetData dt
|
|
let existFiles = -- check whether files exist for given type
|
|
( hasSheetFileQuery sheet (E.val muid) SheetExercise
|
|
, hasSheetFileQuery sheet (E.val muid) SheetHint
|
|
, hasSheetFileQuery sheet (E.val muid) SheetSolution
|
|
, hasSheetFileQuery sheet (E.val muid) SheetMarking
|
|
)
|
|
return (sheet, lastSheetEdit sheet, submission, existFiles)
|
|
, dbtRowKey = \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetId
|
|
, dbtProj = dbtProjFilteredPostId
|
|
, dbtSorting = Map.fromList
|
|
[ ( "name"
|
|
, SortColumn $ \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetName
|
|
)
|
|
, ( "last-edit"
|
|
, SortColumn $ \(sheet `E.LeftOuterJoin` _) -> lastSheetEdit sheet
|
|
)
|
|
, ( "visible-from"
|
|
, SortColumn $ \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetVisibleFrom
|
|
)
|
|
, ( "submission-since"
|
|
, SortColumn $ \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetActiveFrom
|
|
)
|
|
, ( "submission-until"
|
|
, SortColumn $ \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetActiveTo
|
|
)
|
|
, ( "rating"
|
|
, SortColumn $ \(_sheet `E.LeftOuterJoin` (submission `E.InnerJoin` _submissionUser)) -> submission E.?. SubmissionRatingPoints
|
|
)
|
|
-- GitLab Issue $143: HOW TO SORT?
|
|
-- , ( "percent"
|
|
-- , SortColumn $ \(sheet `E.LeftOuterJoin` (submission `E.InnerJoin` _submissionUser)) ->
|
|
-- case sheetType of -- no Haskell inside Esqueleto, right?
|
|
-- (submission E.?. SubmissionRatingPoints) E./. (sheet E.^. SheetType)
|
|
-- )
|
|
]
|
|
, dbtFilter = mconcat
|
|
[ singletonMap "may-access" . mkFilterProjectedPost $ \(Any b) DBRow{..} ->
|
|
let (Entity _ Sheet{..}, _, _, _) = dbrOutput :: (Entity Sheet, E.Value (Maybe UTCTime), Maybe (Entity Submission), (E.Value Bool, E.Value Bool, E.Value Bool, E.Value Bool))
|
|
in (== b) <$> sheetFilter sheetName :: DB Bool
|
|
, singletonMap "rated" . FilterColumn $ \(Any b) -> (E.==. E.val b) . E.isJust . (E.?. SubmissionRatingTime) . querySubmission
|
|
, singletonMap "is-exam" . mkFilterProjectedPost $ \(Any b) DBRow{..} ->
|
|
let (Entity _ Sheet{..}, _, _, _) = dbrOutput :: (Entity Sheet, E.Value (Maybe UTCTime), Maybe (Entity Submission), (E.Value Bool, E.Value Bool, E.Value Bool, E.Value Bool))
|
|
in return $ is _ExamPartPoints sheetType == b :: DB Bool
|
|
]
|
|
, dbtFilterUI = mconcat
|
|
[ flip (prismAForm $ singletonFilter "is-exam" . maybePrism _PathPiece) $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgSheetTypeIsExam)
|
|
, flip (prismAForm $ singletonFilter "rated" . maybePrism _PathPiece) $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgIsRated)
|
|
]
|
|
, dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
|
|
, dbtParams = def
|
|
, dbtIdent = "sheets" :: Text
|
|
, dbtCsvEncode = noCsvEncode
|
|
, dbtCsvDecode = Nothing
|
|
, dbtExtraReps = []
|
|
}
|
|
-- ) ( -- !!!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 raw_statistics -- only over shown rows
|
|
-- foldMap (\(_, E.Value sheetType, E.Value mbPts) -> sheetTypeSum sheetType (join mbPts))
|
|
defaultLayout
|
|
$(widgetFile "sheetList")
|