91 lines
5.1 KiB
Haskell
91 lines
5.1 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 = 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 $ \mPrev -> mconcat
|
|
[ prismAForm (singletonFilter "course" ) mPrev $ aopt (lift `hoistField` selectField courseOptions) (fslI MsgCourse)
|
|
, prismAForm (singletonFilter "term" ) mPrev $ aopt (lift `hoistField` selectField termOptions) (fslI MsgTerm)
|
|
, prismAForm (singletonFilter "school" ) mPrev $ aopt (lift `hoistField` selectField schoolOptions) (fslI MsgCourseSchool)
|
|
, Map.singleton "sheet-search" . maybeToList <$> aopt (lift `hoistField` textField) (fslI MsgSheet) (Just <$> listToMaybe =<< ((Map.lookup "sheet-search" =<< mPrev) <|> (Map.lookup "sheet" =<< mPrev)))
|
|
, prismAForm (singletonFilter "israted" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgRatingTime)
|
|
, prismAForm (singletonFilter "rating-visible" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgRatingDone)
|
|
, prismAForm (singletonFilter "rating" . maybePrism _PathPiece) mPrev $ aopt (lift `hoistField` pointsField) (fslI MsgColumnRatingPoints)
|
|
, Map.singleton "comment" . maybeToList <$> aopt (lift `hoistField` textField) (fslI MsgRatingComment) (Just <$> listToMaybe =<< (Map.lookup "comment" =<< mPrev))
|
|
]
|
|
courseOptions = runDB $ do
|
|
courses <- selectList [] [Asc CourseShorthand] >>= filterM (\(Entity _ Course{..}) -> (== Authorized) <$> evalAccessCorrector courseTerm courseSchool courseShorthand)
|
|
optionsPairs $ map (id &&& id) $ nub $ 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) $ nub $ 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) $ nub $ 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 $ \DBRow{ dbrOutput = (Entity _ sub@Submission{..}, _, _, _, _, _, _, _) } -> (submissionRatingDone sub, submissionRatingPoints, submissionRatingComment)
|
|
|
|
(fmap unFormResult -> tableRes, table) <- runDB $ makeCorrectionsTable whereClause displayColumns filterUI 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")
|