93 lines
4.3 KiB
Haskell
93 lines
4.3 KiB
Haskell
module Handler.Submission.Grade
|
|
( getCorrectionsGradeR, postCorrectionsGradeR
|
|
) where
|
|
|
|
import Import hiding (link)
|
|
|
|
import Handler.Utils hiding (colSchool)
|
|
|
|
import qualified Data.Map.Strict as Map
|
|
|
|
import qualified Data.CaseInsensitive as CI
|
|
|
|
import Data.List (genericLength)
|
|
|
|
import Handler.Submission.List
|
|
|
|
|
|
getCorrectionsGradeR, postCorrectionsGradeR :: Handler Html
|
|
getCorrectionsGradeR = postCorrectionsGradeR
|
|
postCorrectionsGradeR = do
|
|
uid <- requireAuthId
|
|
let whereClause :: CorrectionTableWhere
|
|
whereClause = ratedBy uid
|
|
displayColumns = mconcat -- should match getSSubsR for consistent UX
|
|
[ -- dbRow,
|
|
colSchool
|
|
, colTerm
|
|
, colCourse
|
|
, colSheet
|
|
, colSMatrikel
|
|
, colSubmittors
|
|
, colSGroups
|
|
, colPseudonyms
|
|
, colSubmissionLink
|
|
, colRated
|
|
, colRatedField
|
|
, colPointsField
|
|
, colMaxPointsField
|
|
, colCommentField
|
|
] -- Continue here
|
|
filterUI = Just $ mconcat
|
|
[ filterUICourse courseOptions
|
|
, filterUITerm termOptions
|
|
, filterUISchool schoolOptions
|
|
, filterUISheetSearch
|
|
, filterUIPseudonym
|
|
, filterUIIsRated
|
|
-- , flip (prismAForm $ singletonFilter "rating-visible" . maybePrism _PathPiece) $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgRatingDone)
|
|
, filterUIRating
|
|
, filterUIComment
|
|
]
|
|
courseOptions = runDB $ do
|
|
courses <- selectList [] [Asc CourseShorthand] >>= filterM (\(Entity _ Course{..}) -> (== Authorized) <$> evalAccessCorrector courseTerm courseSchool courseShorthand)
|
|
optionsPairs . map (id &&& id) . nubOrd $ map (CI.original . courseShorthand . entityVal) courses
|
|
termOptions = runDB $ do
|
|
courses <- selectList [] [Asc CourseTerm] >>= filterM (\(Entity _ Course{..}) -> (== Authorized) <$> evalAccessCorrector courseTerm courseSchool courseShorthand)
|
|
optionsPairs . map (id &&& id) . nubOrd $ map (termToText . unTermKey . courseTerm . entityVal) courses
|
|
schoolOptions = runDB $ do
|
|
courses <- selectList [] [Asc CourseSchool] >>= filterM (\(Entity _ Course{..}) -> (== Authorized) <$> evalAccessCorrector courseTerm courseSchool courseShorthand)
|
|
optionsPairs . map (id &&& id) . nubOrd $ map (CI.original . unSchoolKey . courseSchool . entityVal) courses
|
|
psValidator = def
|
|
& restrictAnonymous
|
|
& restrictCorrector
|
|
& defaultSorting [SortDescBy "ratingtime"] :: PSValidator (MForm (HandlerFor UniWorX)) (FormResult (DBFormResult SubmissionId (Bool, Maybe Points, Maybe Text) CorrectionTableData))
|
|
unFormResult = getDBFormResult $ \(view $ resultSubmission . _entityVal -> sub@Submission{..}) -> (submissionRatingDone sub, submissionRatingPoints, submissionRatingComment)
|
|
|
|
(fmap unFormResult -> tableRes, table) <- runDB $ makeCorrectionsTable whereClause displayColumns filterUI Nothing psValidator $ def
|
|
{ dbParamsFormAction = Just $ SomeRoute CorrectionsGradeR
|
|
}
|
|
|
|
formResult tableRes $ \resMap -> do
|
|
now <- liftIO getCurrentTime
|
|
subs <- fmap catMaybes . runDB . forM (Map.toList resMap) $ \(subId, (rated, mPoints, mComment)) -> do
|
|
s@Submission{..} <- get404 subId
|
|
if
|
|
| submissionRatingPoints /= mPoints || submissionRatingComment /= mComment || rated /= submissionRatingDone s
|
|
-> do audit $ TransactionSubmissionEdit subId $ s ^. _submissionSheet
|
|
Just subId <$ update subId [ SubmissionRatingPoints =. mPoints
|
|
, SubmissionRatingComment =. mComment
|
|
, SubmissionRatingBy =. Just uid
|
|
, SubmissionRatingTime =. now <$ guard rated
|
|
]
|
|
| otherwise -> return Nothing
|
|
subs' <- traverse (\x -> (,) <$> encrypt x <*> encrypt x) subs :: Handler [(CryptoFileNameSubmission, CryptoUUIDSubmission)]
|
|
let trigger = [whamlet|_{MsgCorrectionsUploaded (genericLength subs')}|]
|
|
content = Right $(widgetFile "messages/correctionsUploaded")
|
|
unless (null subs') $ addMessageModal Success trigger content
|
|
redirect CorrectionsGradeR
|
|
|
|
siteLayoutMsg MsgCorrectionsGrade $ do
|
|
setTitleI MsgCorrectionsGrade
|
|
$(widgetFile "corrections-grade")
|