diff --git a/src/Application.hs b/src/Application.hs index 00bec22e9..49a6ae0a9 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -109,7 +109,6 @@ import Handler.Course import Handler.Sheet import Handler.Submission import Handler.Tutorial -import Handler.Corrections import Handler.Material import Handler.CryptoIDDispatch import Handler.SystemMessage diff --git a/src/Handler/Course/User.hs b/src/Handler/Course/User.hs index 7d79c51bb..a23a8128e 100644 --- a/src/Handler/Course/User.hs +++ b/src/Handler/Course/User.hs @@ -20,7 +20,7 @@ import Handler.Course.Register import Jobs.Queue -import Handler.Corrections +import Handler.Submission.List import qualified Data.Map as Map import qualified Data.Text as Text diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index f0aa54748..f81ecef61 100644 --- a/src/Handler/Submission.hs +++ b/src/Handler/Submission.hs @@ -6,6 +6,11 @@ module Handler.Submission , module Handler.Submission.Delete , module Handler.Submission.Assign , module Handler.Submission.SubmissionUserInvite + , module Handler.Submission.List + , module Handler.Submission.Correction + , module Handler.Submission.Create + , module Handler.Submission.Grade + , module Handler.Submission.Upload ) where import Handler.Submission.New @@ -14,6 +19,11 @@ import Handler.Submission.Download import Handler.Submission.Delete import Handler.Submission.Assign import Handler.Submission.SubmissionUserInvite (getSInviteR, postSInviteR) +import Handler.Submission.List (getCorrectionsR, postCorrectionsR, getCCorrectionsR, postCCorrectionsR, getSSubsR, postSSubsR) +import Handler.Submission.Correction +import Handler.Submission.Create +import Handler.Submission.Grade +import Handler.Submission.Upload import Import diff --git a/src/Handler/Submission/Assign.hs b/src/Handler/Submission/Assign.hs index 5010f736a..3094607a6 100644 --- a/src/Handler/Submission/Assign.hs +++ b/src/Handler/Submission/Assign.hs @@ -1,10 +1,24 @@ module Handler.Submission.Assign ( getSubAssignR, postSubAssignR + , getCAssignR, postCAssignR + , getSAssignR, postSAssignR ) where -import Import +import Import hiding (link) -import Handler.Utils +import Handler.Utils hiding (colSchool) +import Handler.Utils.Corrections +import Handler.Utils.Submission + +import Data.List as List (foldl, foldr) +import qualified Data.Set as Set +import Data.Map.Strict ((!)) +import qualified Data.Map.Strict as Map + +import qualified Data.Text as Text +import qualified Data.CaseInsensitive as CI + +import qualified Database.Esqueleto as E getSubAssignR, postSubAssignR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> Handler Html @@ -40,3 +54,228 @@ postSubAssignR tid ssh csh shn cID = do defaultLayout $ do setTitleI MsgCorrectorAssignTitle $(widgetFile "submission-assign") + + +data ButtonSubmissionsAssign = BtnSubmissionsAssign + deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable) +instance Universe ButtonSubmissionsAssign +instance Finite ButtonSubmissionsAssign +nullaryPathPiece ''ButtonSubmissionsAssign camelToPathPiece +embedRenderMessage ''UniWorX ''ButtonSubmissionsAssign id +instance Button UniWorX ButtonSubmissionsAssign where + btnClasses BtnSubmissionsAssign = [BCIsButton, BCPrimary] + +getCAssignR, postCAssignR :: TermId -> SchoolId -> CourseShorthand -> Handler Html +getCAssignR = postCAssignR +postCAssignR tid ssh csh = do + cid <- runDB $ getKeyBy404 $ TermSchoolCourseShort tid ssh csh + assignHandler tid ssh csh cid [] + +getSAssignR, postSAssignR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html +getSAssignR = postSAssignR +postSAssignR tid ssh csh shn = do + (shid,cid) <- runDB $ fetchSheetIdCourseId tid ssh csh shn + assignHandler tid ssh csh cid [shid] + +{- TODO: Feature: + make distivt buttons for each sheet, so that users see which sheet will be assigned. + Currently this information is available within the page heading! + + Stub: +data ButtonCorrectionsAssign = BtnCorrectionsAssignAll | BtnCorrectionsAssignSheet SheetName + deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable) +instance Button UniWorX ButtonCorrectionsAssign +-- Are those needed any more? +instance Universe ButtonCorrectionsAssign +instance Finite ButtonCorrectionsAssign +nullaryPathPiece ''ButtonCorrectionsAssign camelToPathPiece +embedRenderMessage ''UniWorX ''ButtonCorrectionsAssign id +instance Button UniWorX ButtonCorrectionsAssign where + btnClasses BtnCorrectionsAssign = [BCIsButton, BCPrimary] +-- use runButtonForm' instead later on +-} + +assignHandler :: TermId -> SchoolId -> CourseShorthand -> CourseId -> [SheetId] -> Handler Html +assignHandler tid ssh csh cid assignSids = do + -- evaluate form first, since it affects DB action + (btnWdgt, btnResult) <- runButtonForm FIDAssignSubmissions + + -- gather data + (orderedSheetNames, assignSheetNames, nrParticipants, groupsPossible, infoMap, correctorMap, assignment) <- runDB $ do + -- cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh + nrParticipants <- count [CourseParticipantCourse ==. cid, CourseParticipantState ==. CourseParticipantActive ] + + sheetList <- selectList [SheetCourse ==. cid] [Desc SheetActiveTo, Desc SheetActiveFrom] + let orderedSheetNames = fmap (\(Entity _ Sheet{sheetName}) -> sheetName) sheetList + sheets = entities2map sheetList + sheetIds = Map.keys sheets + groupsPossible :: Bool + groupsPossible = + let foldFun (Entity _ Sheet{sheetGrouping=sgr}) acc = acc || sgr /= NoGroups + in List.foldr foldFun False sheetList + assignSheetNames = fmap sheetName $ mapMaybe (\sid -> Map.lookup sid sheets) assignSids + + -- plan or assign unassigned submissions for given sheets + let buildA :: (Map SheetName ((Set SubmissionId, Set SubmissionId), Map (Maybe UserId) Int, Map UserId Rational)) -> SheetId -> DB (Map SheetName ((Set SubmissionId, Set SubmissionId), Map (Maybe UserId) Int, Map UserId Rational)) + buildA acc sid = maybeT (return acc) $ do + let shn = sheetName $ sheets ! sid + -- is sheet closed? + guardM $ lift $ hasWriteAccessTo $ CSheetR tid ssh csh shn SAssignR -- we must check, whether the submission is already closed and thus assignable + -- ask for assignment plan + let ignoreExceptions :: AssignSubmissionException -> DB (Map SubmissionId (Maybe UserId), Map UserId Rational) -- silently ignore errors, since we check all sheets and only care about sheets with unassigned corrections + ignoreExceptions NoCorrectors = return mempty + ignoreExceptions NoCorrectorsByProportion = return mempty + ignoreExceptions (SubmissionsNotFound _sids_not_found) = return mempty -- cannot happen, since last argument to planSubmissions is Nothing + (plan,deficit) <- lift $ handle ignoreExceptions $ planSubmissions sid Nothing + guard $ not $ null plan -- only proceed if there is a plan for this sheet + -- implement assignment plan + status <- lift $ case btnResult of + Nothing -> return (Set.empty, Set.empty) + (Just BtnSubmissionsAssign) -> do + status@(sub_ok,sub_fail) <- writeSubmissionPlan plan + let nr_ok = olength sub_ok + nr_fail = olength sub_fail + alert_ok = toMaybe (nr_ok > 0) $ SomeMessage $ MsgUpdatedSheetCorrectorsAutoAssigned nr_ok + alert_fail = toMaybe (nr_fail > 0) $ SomeMessage $ MsgUpdatedSheetCorrectorsAutoFailed nr_fail + msg_status = bool Success Error $ nr_fail > 0 + msg_header = SomeMessage $ shn <> ":" + when (nr_ok > 0 || nr_fail > 0) $ + addMessageI msg_status $ UniWorXMessages $ msg_header : catMaybes [alert_ok, alert_fail] + return status + return $ Map.insert shn (status, countMapElems plan, deficit) acc + assignSids' <- if null assignSids -- assignAll; we distinguish assignSids' here avoid useless Alerts + then selectKeysList [SheetCourse ==. cid] [Asc SheetActiveTo] + else return assignSids + assignment <- foldM buildA Map.empty assignSids' + + correctors <- E.select . E.from $ \(corrector `E.InnerJoin` user) -> do + E.on $ corrector E.^. SheetCorrectorUser E.==. user E.^. UserId + E.where_ $ corrector E.^. SheetCorrectorSheet `E.in_` E.valList sheetIds + return (corrector, user) + let correctorMap' :: Map UserId (User, Map SheetName SheetCorrector) + correctorMap' = (\f -> foldl f Map.empty correctors) + (\acc (Entity _ sheetcorr@SheetCorrector{sheetCorrectorSheet}, Entity uid user) -> + let shn = sheetName $ sheets ! sheetCorrectorSheet + in Map.insertWith (\(usr, ma) (_, mb) -> (usr, Map.union ma mb)) uid (user, Map.singleton shn sheetcorr) acc + ) + -- Lecturers may correct without being enlisted SheetCorrectors, so fetch all names + act_correctors <- E.select . E.distinct . E.from $ \(submission `E.InnerJoin` user) -> do + E.on $ submission E.^. SubmissionRatingBy E.==. (E.just $ user E.^. UserId) + E.where_ $ submission E.^. SubmissionSheet `E.in_` E.valList sheetIds + return (submission E.^. SubmissionSheet, user) + let correctorMap :: Map UserId (User, Map SheetName SheetCorrector) + correctorMap = (\f -> foldl f correctorMap' act_correctors) + (\acc (E.Value sheetCorrectorSheet, Entity uid user) -> + let shn = sheetName $ sheets ! sheetCorrectorSheet + scr = SheetCorrector uid sheetCorrectorSheet mempty CorrectorExcused + in Map.insertWith (\_new old -> old) uid (user, Map.singleton shn scr) acc -- keep already known correctors unchanged + ) + + submissions <- E.select . E.from $ \submission -> do + E.where_ $ submission E.^. SubmissionSheet `E.in_` E.valList sheetIds + let numSubmittors = E.subSelectCount . E.from $ \subUser -> + E.where_ $ submission E.^. SubmissionId E.==. subUser E.^. SubmissionUserSubmission + return (submission, numSubmittors) + -- prepare map + let infoMap :: Map SheetName (Map (Maybe UserId) CorrectionInfo) + infoMap = List.foldl (flip buildS) emptySheets submissions + + -- ensure that all sheets are shown, including those without any submissions + emptySheets = foldl (\m sid -> Map.insert (sheetName $ sheets ! sid) emptyCorrs m) Map.empty sheetIds + emptyCorrs = foldl (\m uid -> let cic = Just uid in + Map.insert cic mempty{ciCorrector=cic} m) Map.empty $ Map.keys correctorMap + + + buildS :: (Entity Submission, E.Value Int64) -> Map SheetName (Map (Maybe UserId) CorrectionInfo) -> Map SheetName (Map (Maybe UserId) CorrectionInfo) + buildS (Entity _sheetId Submission{..}, E.Value nrSbmtrs) m = + let shnm = sheetName $ sheets ! submissionSheet + corTime = diffUTCTime <$> submissionRatingTime <*> submissionRatingAssigned + cinf = Map.singleton submissionRatingBy $ CorrectionInfo + { ciSubmittors = fromIntegral nrSbmtrs + , ciSubmissions = 1 + , ciAssigned = maybe 0 (const 1) submissionRatingBy -- only used in sheetMap + , ciCorrected = maybe 0 (const 1) submissionRatingTime + , ciCorrector = submissionRatingBy + , ciMin = corTime + , ciTot = corTime + , ciMax = corTime + } + in Map.insertWith (Map.unionWith (<>)) shnm cinf m + + return (orderedSheetNames, assignSheetNames, nrParticipants, groupsPossible, infoMap, correctorMap, assignment) + + let -- infoMap :: Map SheetName (Map (Maybe UserId) CorrectionInfo) -- repeated here for easier reference + -- create aggregate maps + + -- Always iterate over orderedSheetNames for consistent sorting! + sheetMap :: Map SheetName CorrectionInfo + sheetMap = Map.map fold infoMap + + sheetLoad :: Map SheetName Load + sheetLoad = -- Map.unionsWith (<>) ((Map.filter () ) . snd) <$> Map.elems correctorMap) + let buildSL acc (_user,mSnSc) = Map.foldlWithKey buildL acc mSnSc + buildL acc s SheetCorrector{sheetCorrectorLoad=l, sheetCorrectorState=CorrectorNormal} + = Map.insertWith (<>) s l acc + buildL acc _ _ = acc + in Map.foldl buildSL Map.empty correctorMap + + deficitMap :: Map UserId Rational + deficitMap = foldMap (view _3) assignment + + corrMap :: Map (Maybe UserId) CorrectionInfo + corrMap = Map.unionsWith (<>) $ Map.elems infoMap + + corrInfos :: [CorrectionInfo] + corrInfos = sortBy (compare `on` (byName . ciCorrector) ) $ Map.elems corrMap + where byName Nothing = Nothing + byName (Just uid) = Map.lookup uid correctorMap + corrMapSum :: CorrectionInfo + corrMapSum = fold corrMap + + let -- whamlet convenience functions + -- avoid nestes hamlet $maybe with duplicated $nothing + getCorrector :: Maybe UserId -> (Widget,Map SheetName SheetCorrector, Text) + getCorrector (Just uid) + | Just (User{..},loadMap) <- Map.lookup uid correctorMap + = (nameEmailWidget userEmail userDisplayName userSurname, loadMap, userDisplayName) + -- | Just (User{..} ) <- Map.lookup uid lecturerNames + -- = (nameEmailWidget userEmail userDisplayName userSurname, mempty) -- lecturers may also correct in rare cases + getCorrector _ = ([whamlet|_{MsgNoCorrectorAssigned}|], mempty, mempty) + -- avoid nestes hamlet $maybe with duplicated $nothing + getCorrSheetStatus :: Maybe UserId -> SheetName -> Maybe CorrectionInfo + getCorrSheetStatus corr shn + | (Just smap) <- Map.lookup shn infoMap + = Map.lookup corr smap + getCorrSheetStatus _ _ = Nothing + -- avoid nestes hamlet $maybe with duplicated $nothing + getCorrNewAssignment :: Maybe UserId -> SheetName -> Maybe Int + getCorrNewAssignment corr shn + | (Just (_,cass,_)) <- Map.lookup shn assignment + = Map.lookup corr cass + getCorrNewAssignment _ _ = Nothing + -- avoid nestes hamlet $maybe with duplicated $nothing + getCorrDeficit :: Maybe UserId -> Maybe Rational + getCorrDeficit (Just uid) = Map.lookup uid deficitMap + getCorrDeficit _ = Nothing + + getLoadSum :: SheetName -> Text + getLoadSum shn | (Just load) <- Map.lookup shn sheetLoad + = showCompactCorrectorLoad load CorrectorNormal + getLoadSum _ = mempty + + showDiffDays :: Maybe NominalDiffTime -> Text + showDiffDays = foldMap formatDiffDays + showAvgsDays :: Maybe NominalDiffTime -> Integer -> Text + showAvgsDays Nothing _ = mempty + showAvgsDays (Just dt) n = formatDiffDays $ dt / fromIntegral n + let headingShort + | 0 < Map.size assignment = MsgMenuCorrectionsAssignSheet $ Text.intercalate ", " $ fmap CI.original $ Map.keys assignment + | otherwise = MsgMenuCorrectionsAssign + headingLong = prependCourseTitle tid ssh csh MsgMenuCorrectionsAssign + + unassignableSheets = filter (\shn -> Map.notMember shn assignment) assignSheetNames + unless (null unassignableSheets) $ addMessageI Warning $ MsgSheetsUnassignable $ Text.intercalate ", " $ fmap CI.original unassignableSheets + + siteLayoutMsg headingShort $ do + setTitleI headingLong + $(widgetFile "corrections-overview") diff --git a/src/Handler/Submission/Correction.hs b/src/Handler/Submission/Correction.hs new file mode 100644 index 000000000..607642eaf --- /dev/null +++ b/src/Handler/Submission/Correction.hs @@ -0,0 +1,154 @@ +module Handler.Submission.Correction + ( getCorrectionR, postCorrectionR + , getCorrectionUserR + ) where + +import Import hiding (link) +-- import System.FilePath (takeFileName) + +import Jobs +import Handler.Utils hiding (colSchool) +import Handler.Utils.Submission + +import qualified Data.Text as Text + +import qualified Control.Monad.State.Class as State + +import qualified Database.Esqueleto as E + +import qualified Data.Conduit.List as C + + +correctionData :: TermId -> SchoolId -> CourseShorthand -> SheetName -> _ -- CryptoFileNameSubmission -> _ +correctionData tid ssh csh shn sub = E.select . E.from $ \((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) -> do + E.on $ corrector E.?. UserId E.==. submission E.^. SubmissionRatingBy + E.on $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId + E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId + E.where_ $ course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + E.&&. sheet E.^. SheetName E.==. E.val shn + E.&&. submission E.^. SubmissionId E.==. E.val sub + return (course, sheet, submission, corrector) + +getCorrectionR, getCorrectionUserR, postCorrectionR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> Handler Html +getCorrectionR tid ssh csh shn cid = do + mayPost <- isAuthorized (CSubmissionR tid ssh csh shn cid CorrectionR) True + bool getCorrectionUserR postCorrectionR (mayPost == Authorized) tid ssh csh shn cid +postCorrectionR tid ssh csh shn cid = do + sub <- decrypt cid + + (results, isLecturer) <- runDB $ (,) + <$> correctionData tid ssh csh shn sub + <*> hasWriteAccessTo (CSheetR tid ssh csh shn SSubsR) + + MsgRenderer mr <- getMsgRenderer + case results of + [(Entity cId Course{..}, Entity shId Sheet{..}, Entity _ subm@Submission{..}, corrector)] -> do + let ratingComment = fmap Text.strip submissionRatingComment >>= (\c -> c <$ guard (not $ null c)) + pointsForm = case sheetType of + NotGraded + -> pure Nothing + (preview _grading -> Just PassBinary) + -> Just <$> apopt (convertField (bool 0 1) (/= 0) checkBoxField) (fslI MsgPassed) submissionRatingPoints + (preview _grading -> Just PassAlways) + -> Just <$> aforced (convertField (bool 0 1) (/= 0) checkBoxField) (fslI MsgPassed) 1 + _otherwise + -> aopt (pointsFieldMax $ preview (_grading . _maxPoints) sheetType) + (fslpI MsgRatingPoints (mr MsgPointsPlaceholder) & setTooltip sheetType) + (Just submissionRatingPoints) + correctorForm + | not isLecturer = wFormToAForm $ pure . Just <$> requireAuthId + | otherwise = wFormToAForm $ do + let correctors = E.from $ \user -> do + let isCorrector = E.exists . E.from $ \sheetCorrector -> + E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. user E.^. UserId + E.&&. sheetCorrector E.^. SheetCorrectorSheet E.==. E.val shId + isLecturer' = E.exists . E.from $ \lecturer -> + E.where_ $ lecturer E.^. LecturerUser E.==. user E.^. UserId + E.&&. lecturer E.^. LecturerCourse E.==. E.val cId + E.where_ $ isCorrector E.||. isLecturer' + return user + wopt (selectField' (Just $ SomeMessage MsgSubmissionNoCorrector) $ userOptionsE correctors) (fslI MsgSubmissionCorrector & setTooltip MsgSubmissionCorrectorTip) (Just submissionRatingBy) + validateCorr = do + (now, ratingBy', rated, ratingPoints', ratingComment') <- State.get + mapM_ tellValidationError $ validateRating sheetType Rating' + { ratingPoints = ratingPoints' + , ratingComment = ratingComment' + , ratingTime = guardOn rated now + } + guardValidation MsgSubmissionCannotBeRatedWithoutCorrector $ isn't _Nothing ratingBy' || not rated + + ((corrResult, corrForm'), corrEncoding) <- runFormPost . validateForm validateCorr . identifyForm FIDcorrection . renderAForm FormStandard $ (,,,,) + <$> wFormToAForm (pure <$> liftIO getCurrentTime) + <*> correctorForm + <*> apopt checkBoxField (fslI MsgRatingDone & setTooltip MsgRatingDoneTip) (Just $ submissionRatingDone Submission{..}) + <*> pointsForm + <*> aopt (textareaField & isoField _Wrapped & cfStrip) (fslI MsgRatingComment) (Just submissionRatingComment) + let corrForm = wrapForm' BtnSave corrForm' def + { formAction = Just . SomeRoute $ CSubmissionR tid ssh csh shn cid CorrectionR + , formEncoding = corrEncoding + } + + ((uploadResult, uploadForm'), uploadEncoding) <- runFormPost . identifyForm FIDcorrectionUpload . renderAForm FormStandard $ + apopt (zipFileField True Nothing) (fslI MsgRatingFiles & setTooltip MsgRatingFilesTip) Nothing + let uploadForm = wrapForm uploadForm' def + { formAction = Just . SomeRoute $ CSubmissionR tid ssh csh shn cid CorrectionR + , formEncoding = uploadEncoding + } + + formResult corrResult $ \(now, ratingBy', rated, ratingPoints', ratingComment') -> do + runDBJobs $ do + update sub [ SubmissionRatingBy =. ratingBy' + , SubmissionRatingTime =. (now <$ guard rated) + , SubmissionRatingPoints =. ratingPoints' + , SubmissionRatingComment =. ratingComment' + ] + + when (rated && is _Nothing submissionRatingTime) $ do + $logDebugS "CorrectionR" [st|Rated #{tshow sub}|] + queueDBJob . JobQueueNotification $ NotificationSubmissionRated sub + + addMessageI Success $ if + | rated -> MsgRatingUpdated + | is _Nothing ratingComment' + , is _Nothing ratingPoints' + , is _Nothing ratingBy' -> MsgRatingDeleted + | is _Nothing ratingComment' + , is _Nothing ratingPoints' -> MsgCorrectorUpdated + | otherwise -> MsgRatingDraftUpdated + redirect $ CSubmissionR tid ssh csh shn cid CorrectionR + + formResult uploadResult $ \fileUploads -> do + uid <- maybeAuthId + + res <- msgSubmissionErrors . runDBJobs . runConduit $ transPipe (lift . lift) fileUploads .| C.mapM (either get404 return) .| extractRatingsMsg .| sinkSubmission uid (Right sub) True + + when (is _Just res) $ do + addMessageI Success MsgRatingFilesUpdated + redirect $ CSubmissionR tid ssh csh shn cid CorrectionR + + let heading = MsgCorrectionHead tid ssh csh shn cid + headingWgt = [whamlet| + $newline never + _{heading} + $if not (submissionRatingDone subm) + \ ^{isVisibleWidget False} + |] + siteLayout headingWgt $ do + setTitleI heading + let userCorrection = $(widgetFile "correction-user") + $(widgetFile "correction") + _ -> notFound + + +getCorrectionUserR tid ssh csh shn cid = do + sub <- decrypt cid + + results <- runDB $ correctionData tid ssh csh shn sub + + case results of + [(Entity _ Course{..}, Entity _ Sheet{..}, Entity _ Submission{..}, corrector@(Just _))] -> + let ratingComment = fmap Text.strip submissionRatingComment >>= (\c -> c <$ guard (not $ null c)) + in defaultLayout $(widgetFile "correction-user") + _ -> notFound diff --git a/src/Handler/Submission/Create.hs b/src/Handler/Submission/Create.hs new file mode 100644 index 000000000..0be823649 --- /dev/null +++ b/src/Handler/Submission/Create.hs @@ -0,0 +1,184 @@ +module Handler.Submission.Create + ( getCorrectionsCreateR, postCorrectionsCreateR + ) where + +import Import hiding (link) +-- import System.FilePath (takeFileName) + +import Jobs +import Handler.Utils hiding (colSchool) + +import qualified Data.Set as Set +import Data.Map.Strict ((!)) +import qualified Data.Map.Strict as Map + +import qualified Data.Text as Text + +import qualified Control.Monad.State.Class as State + +import qualified Database.Esqueleto as E + +import Data.List (genericLength) + + +getCorrectionsCreateR, postCorrectionsCreateR :: Handler Html +getCorrectionsCreateR = postCorrectionsCreateR +postCorrectionsCreateR = do + uid <- requireAuthId + let sheetOptions = mkOptList . toListOf (traverse . filtered (view $ _1 . _Value . _submissionModeCorrector) . _2) <=< runDB $ 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_ + $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val uid + E.&&. sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId + isLecturer = E.exists . E.from $ \lecturer -> E.where_ + $ lecturer E.^. LecturerUser E.==. E.val uid + E.&&. lecturer E.^. LecturerCourse E.==. course E.^. CourseId + E.where_ $ isCorrector E.||. isLecturer + E.orderBy [E.desc $ course E.^. CourseTerm, E.asc $ course E.^. CourseShorthand, E.desc $ sheet E.^. SheetActiveFrom] + return (sheet E.^. SheetSubmissionMode, (sheet E.^. SheetId, course E.^. CourseTerm, course E.^. CourseShorthand, sheet E.^. SheetName)) + mkOptList :: [(E.Value SheetId, E.Value TermId, E.Value CourseShorthand, E.Value SheetName)] -> Handler (OptionList SheetId) + mkOptList opts = do + opts' <- mapM (\v@(E.Value sid, _, _, _) -> (, v) <$> encrypt sid) opts + MsgRenderer mr <- getMsgRenderer + return . mkOptionList $ do + (cID, (E.Value sid, E.Value tid, E.Value csh, E.Value shn)) <- opts' + let tid' = mr $ ShortTermIdentifier (unTermKey tid) + return Option + { optionDisplay = mr $ MsgCorrectionPseudonymSheet tid' csh shn + , optionInternalValue = sid + , optionExternalValue = toPathPiece (cID :: CryptoUUIDSheet) + } + MsgRenderer mr <- getMsgRenderer + ((pseudonymRes, pseudonymWidget), pseudonymEncoding) <- runFormPost . renderAForm FormStandard $ (,) + <$> areq (selectField sheetOptions) (fslI MsgPseudonymSheet) Nothing + <*> (textToList <$> areq textareaField (fslpI MsgCorrectionPseudonyms (mr MsgPseudonyms) & setTooltip MsgCorrectionPseudonymsTip) Nothing) + + case pseudonymRes of + FormMissing -> return () + FormFailure errs -> forM_ errs $ addMessage Error . toHtml + FormSuccess (sid, (pss, invalids)) -> do + allDone <- fmap getAll . execWriterT $ do + forM_ (Map.toList invalids) $ \((oPseudonyms, iPseudonym), alts) -> $(addMessageFile Error "templates/messages/ignoredInvalidPseudonym.hamlet") + tell . All $ null invalids + + WriterT . runDBJobs . mapReaderT (mapWriterT $ fmap ((,) <$> ((,) <$> view (_1 . _1) <*> view _2) <*> view (_1 . _2)) . runWriterT) $ do + Sheet{..} <- get404 sid :: ReaderT SqlBackend (WriterT (Set QueuedJobId) (WriterT All (HandlerFor UniWorX))) Sheet + (sps, unknown) <- fmap partitionEithers' . forM pss . mapM $ \p -> maybe (Left p) Right <$> getBy (UniqueSheetPseudonym sid p) + forM_ unknown $ addMessageI Error . MsgUnknownPseudonym . review _PseudonymText + lift . lift . tell . All $ null unknown + now <- liftIO getCurrentTime + let + sps' :: [[SheetPseudonym]] + duplicate :: Set Pseudonym + ( sps' + , Map.keysSet . Map.filter (\(getSum -> n) -> n > 1) -> duplicate + ) = flip runState Map.empty . forM sps . flip (foldrM :: (Entity SheetPseudonym -> [SheetPseudonym] -> State (Map Pseudonym (Sum Integer)) [SheetPseudonym]) -> [SheetPseudonym] -> [Entity SheetPseudonym] -> State (Map Pseudonym (Sum Integer)) [SheetPseudonym]) [] $ \(Entity _ p@SheetPseudonym{sheetPseudonymPseudonym}) ps -> do + known <- State.gets $ Map.member sheetPseudonymPseudonym + State.modify $ Map.insertWith (<>) sheetPseudonymPseudonym (Sum 1) + return $ bool (p :) id known ps + submissionPrototype = Submission + { submissionSheet = sid + , submissionRatingPoints = Nothing + , submissionRatingComment = Nothing + , submissionRatingBy = Just uid + , submissionRatingAssigned = Just now + , submissionRatingTime = Nothing + } + unless (null duplicate) $ + addMessageModal Warning [whamlet|_{MsgSheetDuplicatePseudonym}|] $ Right $(widgetFile "messages/submissionCreateDuplicates") + existingSubUsers <- E.select . E.from $ \(submissionUser `E.InnerJoin` submission) -> do + E.on $ submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission + E.where_ $ submissionUser E.^. SubmissionUserUser `E.in_` E.valList (sheetPseudonymUser <$> concat sps') + E.&&. submission E.^. SubmissionSheet E.==. E.val sid + return submissionUser + unless (null existingSubUsers) . mapReaderT lift $ do + (Map.toList -> subs) <- foldrM (\(Entity _ SubmissionUser{..}) mp -> Map.insertWith (<>) <$> (encrypt submissionUserSubmission :: _ CryptoFileNameSubmission) <*> pure (Set.fromList . map sheetPseudonymPseudonym . filter (\SheetPseudonym{..} -> sheetPseudonymUser == submissionUserUser) $ concat sps') <*> pure mp) Map.empty existingSubUsers + let trigger = [whamlet|_{MsgSheetCreateExisting}|] + content = Right $(widgetFile "messages/submissionCreateExisting") + addMessageModal Warning trigger content + let sps'' = filter (not . null) $ filter (\spGroup -> not . flip any spGroup $ \SheetPseudonym{sheetPseudonymUser} -> sheetPseudonymUser `elem` map (submissionUserUser . entityVal) existingSubUsers) sps' + forM_ sps'' $ \spGroup + -> let + sheetGroupDesc = Text.intercalate ", " $ map (review _PseudonymText . sheetPseudonymPseudonym) spGroup + in case sheetGrouping of + Arbitrary maxSize -> do + subId <- insert submissionPrototype + void . insert $ SubmissionEdit (Just uid) now subId + audit $ TransactionSubmissionEdit subId sid + insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser + { submissionUserUser = sheetPseudonymUser + , submissionUserSubmission = subId + } + forM_ spGroup $ \SheetPseudonym{sheetPseudonymUser} -> do + hoist (hoist lift) . queueDBJob . JobQueueNotification $ NotificationSubmissionUserCreated sheetPseudonymUser subId + audit $ TransactionSubmissionUserEdit subId sheetPseudonymUser + when (genericLength spGroup > maxSize) $ + addMessageI Warning $ MsgSheetGroupTooLarge sheetGroupDesc + RegisteredGroups -> do + let spGroup' = Map.fromList $ map (sheetPseudonymUser &&& id) spGroup + groups <- E.select . E.from $ \submissionGroup -> do + E.where_ . E.exists . E.from $ \submissionGroupUser -> + E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser `E.in_` E.valList (map sheetPseudonymUser spGroup) + return $ submissionGroup E.^. SubmissionGroupId + groupUsers <- fmap (Set.fromList . map E.unValue) . E.select . E.from $ \submissionGroupUser -> do + E.where_ $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup `E.in_` E.valList (map E.unValue groups) + return $ submissionGroupUser E.^. SubmissionGroupUserUser + if + | [_] <- groups + , Map.keysSet spGroup' `Set.isSubsetOf` groupUsers + -> do + subId <- insert submissionPrototype + void . insert $ SubmissionEdit (Just uid) now subId + audit $ TransactionSubmissionEdit subId sid + insertMany_ . flip map (Set.toList groupUsers) $ \sheetUser -> SubmissionUser + { submissionUserUser = sheetUser + , submissionUserSubmission = subId + } + forM_ groupUsers $ \subUid -> do + hoist (hoist lift) . queueDBJob . JobQueueNotification $ NotificationSubmissionUserCreated subUid subId + audit $ TransactionSubmissionUserEdit subId subUid + when (null groups) $ + addMessageI Warning $ MsgSheetNoRegisteredGroup sheetGroupDesc + | length groups < 2 + -> do + forM_ (Set.toList (Map.keysSet spGroup' `Set.difference` groupUsers)) $ \((spGroup' !) -> SheetPseudonym{sheetPseudonymPseudonym}) -> do + addMessageI Error $ MsgSheetNoRegisteredGroup (review _PseudonymText sheetPseudonymPseudonym) + lift . lift . tell $ All False + | otherwise -> + addMessageI Error $ MsgSheetAmbiguousRegisteredGroup sheetGroupDesc + NoGroups -> do + subId <- insert submissionPrototype + void . insert $ SubmissionEdit (Just uid) now subId + audit $ TransactionSubmissionEdit subId sid + insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser + { submissionUserUser = sheetPseudonymUser + , submissionUserSubmission = subId + } + forM_ spGroup $ \SheetPseudonym{sheetPseudonymUser} -> do + hoist (hoist lift) . queueDBJob . JobQueueNotification $ NotificationSubmissionUserCreated sheetPseudonymUser subId + audit $ TransactionSubmissionUserEdit subId sheetPseudonymUser + when (length spGroup > 1) $ + addMessageI Warning $ MsgSheetNoGroupSubmission sheetGroupDesc + when allDone $ + redirect CorrectionsGradeR + + let pseudonymForm = wrapForm pseudonymWidget def + { formAction = Just $ SomeRoute CorrectionsCreateR + , formEncoding = pseudonymEncoding + } + + siteLayoutMsg MsgCorrCreate $ do + setTitleI MsgCorrCreate + $(widgetFile "corrections-create") + where + partitionEithers' :: [[Either a b]] -> ([[b]], [a]) + partitionEithers' = runWriter . mapM (WriterT . Identity . swap . partitionEithers) + + textToList :: Textarea -> ([[Pseudonym]], Map (Text, Text) [Pseudonym]) + textToList (map (map Text.strip . Text.splitOn ",") . filter (not . Text.null) . map Text.strip . Text.lines . unTextarea -> ws) + = runWriter . fmap (mapMaybe sequence) $ mapM (\ws' -> mapM (toPseudonym ws') ws') ws + where + toPseudonym w' w + | Just res <- w ^? _PseudonymText = return $ Just res + | otherwise = Nothing <$ tell (Map.singleton (Text.intercalate ", " w', w) $ w ^.. pseudonymFragments . _PseudonymWords) diff --git a/src/Handler/Submission/Download.hs b/src/Handler/Submission/Download.hs index 881f27b8e..b15f732a9 100644 --- a/src/Handler/Submission/Download.hs +++ b/src/Handler/Submission/Download.hs @@ -1,6 +1,7 @@ module Handler.Submission.Download ( getSubDownloadR , getSubArchiveR + , getCorrectionsDownloadR ) where import Import @@ -8,6 +9,8 @@ import Import import Handler.Utils import Handler.Utils.Submission +import qualified Data.Set as Set + import qualified Data.Text.Encoding as Text import qualified Database.Esqueleto as E @@ -69,3 +72,16 @@ getSubArchiveR tid ssh csh shn cID sfType = do maybe (return ()) (yieldM . ratingFile cID) rating serveSomeFiles archiveName source + + +getCorrectionsDownloadR :: Handler TypedContent +getCorrectionsDownloadR = do -- download all assigned and open submissions + uid <- requireAuthId + subs <- runDB $ selectKeysList + [ SubmissionRatingBy ==. Just uid + , SubmissionRatingTime ==. Nothing + ] [] + when (null subs) $ do + addMessageI Info MsgNoOpenSubmissions + redirect CorrectionsR + submissionMultiArchive SubmissionDownloadAnonymous $ Set.fromList subs diff --git a/src/Handler/Submission/Grade.hs b/src/Handler/Submission/Grade.hs new file mode 100644 index 000000000..9ea8316d9 --- /dev/null +++ b/src/Handler/Submission/Grade.hs @@ -0,0 +1,90 @@ +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") diff --git a/src/Handler/Corrections.hs b/src/Handler/Submission/List.hs similarity index 53% rename from src/Handler/Corrections.hs rename to src/Handler/Submission/List.hs index 44b1e4d6a..1f892a5bf 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Submission/List.hs @@ -1,60 +1,34 @@ -module Handler.Corrections +module Handler.Submission.List ( getCorrectionsR, postCorrectionsR , getCCorrectionsR, postCCorrectionsR , getSSubsR, postSSubsR - , getCorrectionR, postCorrectionR - , getCorrectionsUploadR, postCorrectionsUploadR - , getCorrectionsCreateR, postCorrectionsCreateR - , getCorrectionsGradeR, postCorrectionsGradeR - , getCAssignR, postCAssignR - , getSAssignR, postSAssignR - , getCorrectionsDownloadR , correctionsR' + , restrictAnonymous, restrictCorrector , ratedBy, courseIs, sheetIs, userIs - , colTerm, colSchool, colCourse, colSheet, colCorrector, colSubmissionLink, colSelect, colSubmittors, colSMatrikel, colRating, colAssigned, colRated, colPseudonyms, colRatedField, colPointsField, colMaxPointsField, colCommentField, colLastEdit + , colTerm, colSchool, colCourse, colSheet, colCorrector, colSubmissionLink, colSelect, colSubmittors, colSMatrikel, colRating, colAssigned, colRated, colPseudonyms, colRatedField, colPointsField, colMaxPointsField, colCommentField, colLastEdit, colSGroups , makeCorrectionsTable + , CorrectionTableData , ActionCorrections(..), downloadAction, deleteAction, assignAction, autoAssignAction ) where import Import hiding (link) --- import System.FilePath (takeFileName) -import Jobs import Handler.Utils hiding (colSchool) -import Handler.Utils.Corrections import Handler.Utils.Submission import Handler.Utils.SheetType import Handler.Utils.Delete --- import Handler.Utils.Zip -import Data.List as List (foldl, foldr) +import Data.List as List (foldr) import qualified Data.Set as Set -import Data.Map.Strict ((!)) import qualified Data.Map.Strict as Map import qualified Data.Text as Text import qualified Data.CaseInsensitive as CI -import qualified Control.Monad.State.Class as State - --- import Data.Time --- import Data.Function ((&)) --- --- import Colonnade hiding (fromMaybe, singleton, bool) --- import Yesod.Colonnade --- --- import qualified Data.UUID.Cryptographic as UUID --- import qualified Data.Conduit.List as C - import Database.Esqueleto.Utils.TH import qualified Database.Esqueleto as E import qualified Database.Esqueleto.Utils as E import qualified Database.Esqueleto.Internal.Language (From) --- import qualified Database.Esqueleto.Internal.Sql as E - --- import Control.Monad.Writer (MonadWriter(..), execWriterT) - --- import Network.Mime import Text.Hamlet (ihamletFile) @@ -62,9 +36,6 @@ import Database.Persist.Sql (updateWhereCount) import Data.List (genericLength) -import qualified Data.Conduit.List as C - - type CorrectionTableExpr = (E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity Submission)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User)) type CorrectionTableWhere = CorrectionTableExpr -> E.SqlExpr (E.Value Bool) @@ -108,8 +79,6 @@ userIs uid ((_course `E.InnerJoin` _sheet `E.InnerJoin` submission) `E.LeftOute E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId E.&&. submissionUser E.^. SubmissionUserUser E.==. E.val uid - - -- Columns colTerm :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) colTerm = sortable (Just "term") (i18nCell MsgTerm) @@ -228,7 +197,7 @@ colPointsField = sortable (Just "rating") (i18nCell MsgColumnRatingPoints) $ for _other -> over (_1.mapped) (_2 .~) . over _2 fvWidget <$> mopt (pointsFieldMax $ preview (_grading . _maxPoints) sheetType) (fsUniq mkUnique "points") (Just submissionRatingPoints) ) -colMaxPointsField :: Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId (a, Maybe Points, b) CorrectionTableData))) +colMaxPointsField :: _ => Colonnade Sortable CorrectionTableData (DBCell m (FormResult (DBFormResult SubmissionId (a, Maybe Points, b) CorrectionTableData))) colMaxPointsField = sortable (Just "sheet-type") (i18nCell MsgSheetType) $ i18nCell . (\DBRow{ dbrOutput=(_, Entity _ Sheet{sheetType}, _, _, _, _, _, _) } -> sheetType) colCommentField :: Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId (a, b, Maybe Text) CorrectionTableData))) @@ -656,6 +625,7 @@ autoAssignAction shid = ( CorrAutoSetCorrector , pure $ CorrAutoSetCorrectorData shid ) + getCorrectionsR, postCorrectionsR :: Handler TypedContent getCorrectionsR = postCorrectionsR postCorrectionsR = do @@ -772,644 +742,3 @@ postSSubsR tid ssh csh shn = do , autoAssignAction shid , deleteAction ] - -correctionData :: TermId -> SchoolId -> CourseShorthand -> SheetName -> _ -- CryptoFileNameSubmission -> _ -correctionData tid ssh csh shn sub = E.select . E.from $ \((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) -> do - E.on $ corrector E.?. UserId E.==. submission E.^. SubmissionRatingBy - E.on $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId - E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId - E.where_ $ course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseSchool E.==. E.val ssh - E.&&. course E.^. CourseShorthand E.==. E.val csh - E.&&. sheet E.^. SheetName E.==. E.val shn - E.&&. submission E.^. SubmissionId E.==. E.val sub - return (course, sheet, submission, corrector) - -getCorrectionR, getCorrectionUserR, postCorrectionR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> Handler Html -getCorrectionR tid ssh csh shn cid = do - mayPost <- isAuthorized (CSubmissionR tid ssh csh shn cid CorrectionR) True - bool getCorrectionUserR postCorrectionR (mayPost == Authorized) tid ssh csh shn cid -postCorrectionR tid ssh csh shn cid = do - sub <- decrypt cid - - (results, isLecturer) <- runDB $ (,) - <$> correctionData tid ssh csh shn sub - <*> hasWriteAccessTo (CSheetR tid ssh csh shn SSubsR) - - MsgRenderer mr <- getMsgRenderer - case results of - [(Entity cId Course{..}, Entity shId Sheet{..}, Entity _ subm@Submission{..}, corrector)] -> do - let ratingComment = fmap Text.strip submissionRatingComment >>= (\c -> c <$ guard (not $ null c)) - pointsForm = case sheetType of - NotGraded - -> pure Nothing - (preview _grading -> Just PassBinary) - -> Just <$> apopt (convertField (bool 0 1) (/= 0) checkBoxField) (fslI MsgPassed) submissionRatingPoints - (preview _grading -> Just PassAlways) - -> Just <$> aforced (convertField (bool 0 1) (/= 0) checkBoxField) (fslI MsgPassed) 1 - _otherwise - -> aopt (pointsFieldMax $ preview (_grading . _maxPoints) sheetType) - (fslpI MsgRatingPoints (mr MsgPointsPlaceholder) & setTooltip sheetType) - (Just submissionRatingPoints) - correctorForm - | not isLecturer = wFormToAForm $ pure . Just <$> requireAuthId - | otherwise = wFormToAForm $ do - let correctors = E.from $ \user -> do - let isCorrector = E.exists . E.from $ \sheetCorrector -> - E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. user E.^. UserId - E.&&. sheetCorrector E.^. SheetCorrectorSheet E.==. E.val shId - isLecturer' = E.exists . E.from $ \lecturer -> - E.where_ $ lecturer E.^. LecturerUser E.==. user E.^. UserId - E.&&. lecturer E.^. LecturerCourse E.==. E.val cId - E.where_ $ isCorrector E.||. isLecturer' - return user - wopt (selectField' (Just $ SomeMessage MsgSubmissionNoCorrector) $ userOptionsE correctors) (fslI MsgSubmissionCorrector & setTooltip MsgSubmissionCorrectorTip) (Just submissionRatingBy) - validateCorr = do - (now, ratingBy', rated, ratingPoints', ratingComment') <- State.get - mapM_ tellValidationError $ validateRating sheetType Rating' - { ratingPoints = ratingPoints' - , ratingComment = ratingComment' - , ratingTime = guardOn rated now - } - guardValidation MsgSubmissionCannotBeRatedWithoutCorrector $ isn't _Nothing ratingBy' || not rated - - ((corrResult, corrForm'), corrEncoding) <- runFormPost . validateForm validateCorr . identifyForm FIDcorrection . renderAForm FormStandard $ (,,,,) - <$> wFormToAForm (pure <$> liftIO getCurrentTime) - <*> correctorForm - <*> apopt checkBoxField (fslI MsgRatingDone & setTooltip MsgRatingDoneTip) (Just $ submissionRatingDone Submission{..}) - <*> pointsForm - <*> aopt (textareaField & isoField _Wrapped & cfStrip) (fslI MsgRatingComment) (Just submissionRatingComment) - let corrForm = wrapForm' BtnSave corrForm' def - { formAction = Just . SomeRoute $ CSubmissionR tid ssh csh shn cid CorrectionR - , formEncoding = corrEncoding - } - - ((uploadResult, uploadForm'), uploadEncoding) <- runFormPost . identifyForm FIDcorrectionUpload . renderAForm FormStandard $ - apopt (zipFileField True Nothing) (fslI MsgRatingFiles & setTooltip MsgRatingFilesTip) Nothing - let uploadForm = wrapForm uploadForm' def - { formAction = Just . SomeRoute $ CSubmissionR tid ssh csh shn cid CorrectionR - , formEncoding = uploadEncoding - } - - formResult corrResult $ \(now, ratingBy', rated, ratingPoints', ratingComment') -> do - runDBJobs $ do - update sub [ SubmissionRatingBy =. ratingBy' - , SubmissionRatingTime =. (now <$ guard rated) - , SubmissionRatingPoints =. ratingPoints' - , SubmissionRatingComment =. ratingComment' - ] - - when (rated && is _Nothing submissionRatingTime) $ do - $logDebugS "CorrectionR" [st|Rated #{tshow sub}|] - queueDBJob . JobQueueNotification $ NotificationSubmissionRated sub - - addMessageI Success $ if - | rated -> MsgRatingUpdated - | is _Nothing ratingComment' - , is _Nothing ratingPoints' - , is _Nothing ratingBy' -> MsgRatingDeleted - | is _Nothing ratingComment' - , is _Nothing ratingPoints' -> MsgCorrectorUpdated - | otherwise -> MsgRatingDraftUpdated - redirect $ CSubmissionR tid ssh csh shn cid CorrectionR - - formResult uploadResult $ \fileUploads -> do - uid <- maybeAuthId - - res <- msgSubmissionErrors . runDBJobs . runConduit $ transPipe (lift . lift) fileUploads .| C.mapM (either get404 return) .| extractRatingsMsg .| sinkSubmission uid (Right sub) True - - when (is _Just res) $ do - addMessageI Success MsgRatingFilesUpdated - redirect $ CSubmissionR tid ssh csh shn cid CorrectionR - - let heading = MsgCorrectionHead tid ssh csh shn cid - headingWgt = [whamlet| - $newline never - _{heading} - $if not (submissionRatingDone subm) - \ ^{isVisibleWidget False} - |] - siteLayout headingWgt $ do - setTitleI heading - let userCorrection = $(widgetFile "correction-user") - $(widgetFile "correction") - _ -> notFound - - -getCorrectionUserR tid ssh csh shn cid = do - sub <- decrypt cid - - results <- runDB $ correctionData tid ssh csh shn sub - - case results of - [(Entity _ Course{..}, Entity _ Sheet{..}, Entity _ Submission{..}, corrector@(Just _))] -> - let ratingComment = fmap Text.strip submissionRatingComment >>= (\c -> c <$ guard (not $ null c)) - in defaultLayout $(widgetFile "correction-user") - _ -> notFound - - -getCorrectionsUploadR, postCorrectionsUploadR :: Handler Html -getCorrectionsUploadR = postCorrectionsUploadR -postCorrectionsUploadR = do - ((uploadRes, upload), uploadEncoding) <- runFormPost . identifyForm FIDcorrectionsUpload . renderAForm FormStandard $ - areq (zipFileField True Nothing) (fslI MsgCorrUploadField) Nothing - - case uploadRes of - FormMissing -> return () - FormFailure errs -> mapM_ (addMessage Error . toHtml) errs - FormSuccess files -> do - uid <- requireAuthId - mbSubs <- msgSubmissionErrors . runDBJobs . runConduit $ transPipe (lift . lift) files .| C.mapM (either get404 return) .| extractRatingsMsg .| sinkMultiSubmission uid True - case mbSubs of - Nothing -> return () - (Just subs) - | null subs -> addMessageI Warning MsgNoCorrectionsUploaded - | otherwise -> do - subs' <- traverse (\x -> (,) <$> encrypt x <*> encrypt x) $ Set.toList subs :: Handler [(CryptoFileNameSubmission, CryptoUUIDSubmission)] - let trigger = [whamlet|_{MsgCorrectionsUploaded (genericLength subs')}|] - content = Right $(widgetFile "messages/correctionsUploaded") - addMessageModal Success trigger content - - let uploadForm = wrapForm upload def - { formAction = Just $ SomeRoute CorrectionsUploadR - , formEncoding = uploadEncoding - } - - maxUploadMB <- appMaximumContentLength <$> getsYesod appSettings' - - defaultLayout $ do - let uploadInstruction = $(i18nWidgetFile "corrections-upload-instructions") - $(widgetFile "corrections-upload") - -getCorrectionsCreateR, postCorrectionsCreateR :: Handler Html -getCorrectionsCreateR = postCorrectionsCreateR -postCorrectionsCreateR = do - uid <- requireAuthId - let sheetOptions = mkOptList . toListOf (traverse . filtered (view $ _1 . _Value . _submissionModeCorrector) . _2) <=< runDB $ 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_ - $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val uid - E.&&. sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId - isLecturer = E.exists . E.from $ \lecturer -> E.where_ - $ lecturer E.^. LecturerUser E.==. E.val uid - E.&&. lecturer E.^. LecturerCourse E.==. course E.^. CourseId - E.where_ $ isCorrector E.||. isLecturer - E.orderBy [E.desc $ course E.^. CourseTerm, E.asc $ course E.^. CourseShorthand, E.desc $ sheet E.^. SheetActiveFrom] - return (sheet E.^. SheetSubmissionMode, (sheet E.^. SheetId, course E.^. CourseTerm, course E.^. CourseShorthand, sheet E.^. SheetName)) - mkOptList :: [(E.Value SheetId, E.Value TermId, E.Value CourseShorthand, E.Value SheetName)] -> Handler (OptionList SheetId) - mkOptList opts = do - opts' <- mapM (\v@(E.Value sid, _, _, _) -> (, v) <$> encrypt sid) opts - MsgRenderer mr <- getMsgRenderer - return . mkOptionList $ do - (cID, (E.Value sid, E.Value tid, E.Value csh, E.Value shn)) <- opts' - let tid' = mr $ ShortTermIdentifier (unTermKey tid) - return Option - { optionDisplay = mr $ MsgCorrectionPseudonymSheet tid' csh shn - , optionInternalValue = sid - , optionExternalValue = toPathPiece (cID :: CryptoUUIDSheet) - } - MsgRenderer mr <- getMsgRenderer - ((pseudonymRes, pseudonymWidget), pseudonymEncoding) <- runFormPost . renderAForm FormStandard $ (,) - <$> areq (selectField sheetOptions) (fslI MsgPseudonymSheet) Nothing - <*> (textToList <$> areq textareaField (fslpI MsgCorrectionPseudonyms (mr MsgPseudonyms) & setTooltip MsgCorrectionPseudonymsTip) Nothing) - - case pseudonymRes of - FormMissing -> return () - FormFailure errs -> forM_ errs $ addMessage Error . toHtml - FormSuccess (sid, (pss, invalids)) -> do - allDone <- fmap getAll . execWriterT $ do - forM_ (Map.toList invalids) $ \((oPseudonyms, iPseudonym), alts) -> $(addMessageFile Error "templates/messages/ignoredInvalidPseudonym.hamlet") - tell . All $ null invalids - - WriterT . runDBJobs . mapReaderT (mapWriterT $ fmap ((,) <$> ((,) <$> view (_1 . _1) <*> view _2) <*> view (_1 . _2)) . runWriterT) $ do - Sheet{..} <- get404 sid :: ReaderT SqlBackend (WriterT (Set QueuedJobId) (WriterT All (HandlerFor UniWorX))) Sheet - (sps, unknown) <- fmap partitionEithers' . forM pss . mapM $ \p -> maybe (Left p) Right <$> getBy (UniqueSheetPseudonym sid p) - forM_ unknown $ addMessageI Error . MsgUnknownPseudonym . review _PseudonymText - lift . lift . tell . All $ null unknown - now <- liftIO getCurrentTime - let - sps' :: [[SheetPseudonym]] - duplicate :: Set Pseudonym - ( sps' - , Map.keysSet . Map.filter (\(getSum -> n) -> n > 1) -> duplicate - ) = flip runState Map.empty . forM sps . flip (foldrM :: (Entity SheetPseudonym -> [SheetPseudonym] -> State (Map Pseudonym (Sum Integer)) [SheetPseudonym]) -> [SheetPseudonym] -> [Entity SheetPseudonym] -> State (Map Pseudonym (Sum Integer)) [SheetPseudonym]) [] $ \(Entity _ p@SheetPseudonym{sheetPseudonymPseudonym}) ps -> do - known <- State.gets $ Map.member sheetPseudonymPseudonym - State.modify $ Map.insertWith (<>) sheetPseudonymPseudonym (Sum 1) - return $ bool (p :) id known ps - submissionPrototype = Submission - { submissionSheet = sid - , submissionRatingPoints = Nothing - , submissionRatingComment = Nothing - , submissionRatingBy = Just uid - , submissionRatingAssigned = Just now - , submissionRatingTime = Nothing - } - unless (null duplicate) $ - addMessageModal Warning [whamlet|_{MsgSheetDuplicatePseudonym}|] $ Right $(widgetFile "messages/submissionCreateDuplicates") - existingSubUsers <- E.select . E.from $ \(submissionUser `E.InnerJoin` submission) -> do - E.on $ submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission - E.where_ $ submissionUser E.^. SubmissionUserUser `E.in_` E.valList (sheetPseudonymUser <$> concat sps') - E.&&. submission E.^. SubmissionSheet E.==. E.val sid - return submissionUser - unless (null existingSubUsers) . mapReaderT lift $ do - (Map.toList -> subs) <- foldrM (\(Entity _ SubmissionUser{..}) mp -> Map.insertWith (<>) <$> (encrypt submissionUserSubmission :: _ CryptoFileNameSubmission) <*> pure (Set.fromList . map sheetPseudonymPseudonym . filter (\SheetPseudonym{..} -> sheetPseudonymUser == submissionUserUser) $ concat sps') <*> pure mp) Map.empty existingSubUsers - let trigger = [whamlet|_{MsgSheetCreateExisting}|] - content = Right $(widgetFile "messages/submissionCreateExisting") - addMessageModal Warning trigger content - let sps'' = filter (not . null) $ filter (\spGroup -> not . flip any spGroup $ \SheetPseudonym{sheetPseudonymUser} -> sheetPseudonymUser `elem` map (submissionUserUser . entityVal) existingSubUsers) sps' - forM_ sps'' $ \spGroup - -> let - sheetGroupDesc = Text.intercalate ", " $ map (review _PseudonymText . sheetPseudonymPseudonym) spGroup - in case sheetGrouping of - Arbitrary maxSize -> do - subId <- insert submissionPrototype - void . insert $ SubmissionEdit (Just uid) now subId - audit $ TransactionSubmissionEdit subId sid - insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser - { submissionUserUser = sheetPseudonymUser - , submissionUserSubmission = subId - } - forM_ spGroup $ \SheetPseudonym{sheetPseudonymUser} -> do - hoist (hoist lift) . queueDBJob . JobQueueNotification $ NotificationSubmissionUserCreated sheetPseudonymUser subId - audit $ TransactionSubmissionUserEdit subId sheetPseudonymUser - when (genericLength spGroup > maxSize) $ - addMessageI Warning $ MsgSheetGroupTooLarge sheetGroupDesc - RegisteredGroups -> do - let spGroup' = Map.fromList $ map (sheetPseudonymUser &&& id) spGroup - groups <- E.select . E.from $ \submissionGroup -> do - E.where_ . E.exists . E.from $ \submissionGroupUser -> - E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser `E.in_` E.valList (map sheetPseudonymUser spGroup) - return $ submissionGroup E.^. SubmissionGroupId - groupUsers <- fmap (Set.fromList . map E.unValue) . E.select . E.from $ \submissionGroupUser -> do - E.where_ $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup `E.in_` E.valList (map E.unValue groups) - return $ submissionGroupUser E.^. SubmissionGroupUserUser - if - | [_] <- groups - , Map.keysSet spGroup' `Set.isSubsetOf` groupUsers - -> do - subId <- insert submissionPrototype - void . insert $ SubmissionEdit (Just uid) now subId - audit $ TransactionSubmissionEdit subId sid - insertMany_ . flip map (Set.toList groupUsers) $ \sheetUser -> SubmissionUser - { submissionUserUser = sheetUser - , submissionUserSubmission = subId - } - forM_ groupUsers $ \subUid -> do - hoist (hoist lift) . queueDBJob . JobQueueNotification $ NotificationSubmissionUserCreated subUid subId - audit $ TransactionSubmissionUserEdit subId subUid - when (null groups) $ - addMessageI Warning $ MsgSheetNoRegisteredGroup sheetGroupDesc - | length groups < 2 - -> do - forM_ (Set.toList (Map.keysSet spGroup' `Set.difference` groupUsers)) $ \((spGroup' !) -> SheetPseudonym{sheetPseudonymPseudonym}) -> do - addMessageI Error $ MsgSheetNoRegisteredGroup (review _PseudonymText sheetPseudonymPseudonym) - lift . lift . tell $ All False - | otherwise -> - addMessageI Error $ MsgSheetAmbiguousRegisteredGroup sheetGroupDesc - NoGroups -> do - subId <- insert submissionPrototype - void . insert $ SubmissionEdit (Just uid) now subId - audit $ TransactionSubmissionEdit subId sid - insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser - { submissionUserUser = sheetPseudonymUser - , submissionUserSubmission = subId - } - forM_ spGroup $ \SheetPseudonym{sheetPseudonymUser} -> do - hoist (hoist lift) . queueDBJob . JobQueueNotification $ NotificationSubmissionUserCreated sheetPseudonymUser subId - audit $ TransactionSubmissionUserEdit subId sheetPseudonymUser - when (length spGroup > 1) $ - addMessageI Warning $ MsgSheetNoGroupSubmission sheetGroupDesc - when allDone $ - redirect CorrectionsGradeR - - let pseudonymForm = wrapForm pseudonymWidget def - { formAction = Just $ SomeRoute CorrectionsCreateR - , formEncoding = pseudonymEncoding - } - - siteLayoutMsg MsgCorrCreate $ do - setTitleI MsgCorrCreate - $(widgetFile "corrections-create") - where - partitionEithers' :: [[Either a b]] -> ([[b]], [a]) - partitionEithers' = runWriter . mapM (WriterT . Identity . swap . partitionEithers) - - textToList :: Textarea -> ([[Pseudonym]], Map (Text, Text) [Pseudonym]) - textToList (map (map Text.strip . Text.splitOn ",") . filter (not . Text.null) . map Text.strip . Text.lines . unTextarea -> ws) - = runWriter . fmap (mapMaybe sequence) $ mapM (\ws' -> mapM (toPseudonym ws') ws') ws - where - toPseudonym w' w - | Just res <- w ^? _PseudonymText = return $ Just res - | otherwise = Nothing <$ tell (Map.singleton (Text.intercalate ", " w', w) $ w ^.. pseudonymFragments . _PseudonymWords) - -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") - - -data ButtonSubmissionsAssign = BtnSubmissionsAssign - deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable) -instance Universe ButtonSubmissionsAssign -instance Finite ButtonSubmissionsAssign -nullaryPathPiece ''ButtonSubmissionsAssign camelToPathPiece -embedRenderMessage ''UniWorX ''ButtonSubmissionsAssign id -instance Button UniWorX ButtonSubmissionsAssign where - btnClasses BtnSubmissionsAssign = [BCIsButton, BCPrimary] - -getCAssignR, postCAssignR :: TermId -> SchoolId -> CourseShorthand -> Handler Html -getCAssignR = postCAssignR -postCAssignR tid ssh csh = do - cid <- runDB $ getKeyBy404 $ TermSchoolCourseShort tid ssh csh - assignHandler tid ssh csh cid [] - -getSAssignR, postSAssignR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html -getSAssignR = postSAssignR -postSAssignR tid ssh csh shn = do - (shid,cid) <- runDB $ fetchSheetIdCourseId tid ssh csh shn - assignHandler tid ssh csh cid [shid] - -{- TODO: Feature: - make distivt buttons for each sheet, so that users see which sheet will be assigned. - Currently this information is available within the page heading! - - Stub: -data ButtonCorrectionsAssign = BtnCorrectionsAssignAll | BtnCorrectionsAssignSheet SheetName - deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable) -instance Button UniWorX ButtonCorrectionsAssign --- Are those needed any more? -instance Universe ButtonCorrectionsAssign -instance Finite ButtonCorrectionsAssign -nullaryPathPiece ''ButtonCorrectionsAssign camelToPathPiece -embedRenderMessage ''UniWorX ''ButtonCorrectionsAssign id -instance Button UniWorX ButtonCorrectionsAssign where - btnClasses BtnCorrectionsAssign = [BCIsButton, BCPrimary] --- use runButtonForm' instead later on --} - -assignHandler :: TermId -> SchoolId -> CourseShorthand -> CourseId -> [SheetId] -> Handler Html -assignHandler tid ssh csh cid assignSids = do - -- evaluate form first, since it affects DB action - (btnWdgt, btnResult) <- runButtonForm FIDAssignSubmissions - - -- gather data - (orderedSheetNames, assignSheetNames, nrParticipants, groupsPossible, infoMap, correctorMap, assignment) <- runDB $ do - -- cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh - nrParticipants <- count [CourseParticipantCourse ==. cid, CourseParticipantState ==. CourseParticipantActive ] - - sheetList <- selectList [SheetCourse ==. cid] [Desc SheetActiveTo, Desc SheetActiveFrom] - let orderedSheetNames = fmap (\(Entity _ Sheet{sheetName}) -> sheetName) sheetList - sheets = entities2map sheetList - sheetIds = Map.keys sheets - groupsPossible :: Bool - groupsPossible = - let foldFun (Entity _ Sheet{sheetGrouping=sgr}) acc = acc || sgr /= NoGroups - in List.foldr foldFun False sheetList - assignSheetNames = fmap sheetName $ mapMaybe (\sid -> Map.lookup sid sheets) assignSids - - -- plan or assign unassigned submissions for given sheets - let buildA :: (Map SheetName ((Set SubmissionId, Set SubmissionId), Map (Maybe UserId) Int, Map UserId Rational)) -> SheetId -> DB (Map SheetName ((Set SubmissionId, Set SubmissionId), Map (Maybe UserId) Int, Map UserId Rational)) - buildA acc sid = maybeT (return acc) $ do - let shn = sheetName $ sheets ! sid - -- is sheet closed? - guardM $ lift $ hasWriteAccessTo $ CSheetR tid ssh csh shn SAssignR -- we must check, whether the submission is already closed and thus assignable - -- ask for assignment plan - let ignoreExceptions :: AssignSubmissionException -> DB (Map SubmissionId (Maybe UserId), Map UserId Rational) -- silently ignore errors, since we check all sheets and only care about sheets with unassigned corrections - ignoreExceptions NoCorrectors = return mempty - ignoreExceptions NoCorrectorsByProportion = return mempty - ignoreExceptions (SubmissionsNotFound _sids_not_found) = return mempty -- cannot happen, since last argument to planSubmissions is Nothing - (plan,deficit) <- lift $ handle ignoreExceptions $ planSubmissions sid Nothing - guard $ not $ null plan -- only proceed if there is a plan for this sheet - -- implement assignment plan - status <- lift $ case btnResult of - Nothing -> return (Set.empty, Set.empty) - (Just BtnSubmissionsAssign) -> do - status@(sub_ok,sub_fail) <- writeSubmissionPlan plan - let nr_ok = olength sub_ok - nr_fail = olength sub_fail - alert_ok = toMaybe (nr_ok > 0) $ SomeMessage $ MsgUpdatedSheetCorrectorsAutoAssigned nr_ok - alert_fail = toMaybe (nr_fail > 0) $ SomeMessage $ MsgUpdatedSheetCorrectorsAutoFailed nr_fail - msg_status = bool Success Error $ nr_fail > 0 - msg_header = SomeMessage $ shn <> ":" - when (nr_ok > 0 || nr_fail > 0) $ - addMessageI msg_status $ UniWorXMessages $ msg_header : catMaybes [alert_ok, alert_fail] - return status - return $ Map.insert shn (status, countMapElems plan, deficit) acc - assignSids' <- if null assignSids -- assignAll; we distinguish assignSids' here avoid useless Alerts - then selectKeysList [SheetCourse ==. cid] [Asc SheetActiveTo] - else return assignSids - assignment <- foldM buildA Map.empty assignSids' - - correctors <- E.select . E.from $ \(corrector `E.InnerJoin` user) -> do - E.on $ corrector E.^. SheetCorrectorUser E.==. user E.^. UserId - E.where_ $ corrector E.^. SheetCorrectorSheet `E.in_` E.valList sheetIds - return (corrector, user) - let correctorMap' :: Map UserId (User, Map SheetName SheetCorrector) - correctorMap' = (\f -> foldl f Map.empty correctors) - (\acc (Entity _ sheetcorr@SheetCorrector{sheetCorrectorSheet}, Entity uid user) -> - let shn = sheetName $ sheets ! sheetCorrectorSheet - in Map.insertWith (\(usr, ma) (_, mb) -> (usr, Map.union ma mb)) uid (user, Map.singleton shn sheetcorr) acc - ) - -- Lecturers may correct without being enlisted SheetCorrectors, so fetch all names - act_correctors <- E.select . E.distinct . E.from $ \(submission `E.InnerJoin` user) -> do - E.on $ submission E.^. SubmissionRatingBy E.==. (E.just $ user E.^. UserId) - E.where_ $ submission E.^. SubmissionSheet `E.in_` E.valList sheetIds - return (submission E.^. SubmissionSheet, user) - let correctorMap :: Map UserId (User, Map SheetName SheetCorrector) - correctorMap = (\f -> foldl f correctorMap' act_correctors) - (\acc (E.Value sheetCorrectorSheet, Entity uid user) -> - let shn = sheetName $ sheets ! sheetCorrectorSheet - scr = SheetCorrector uid sheetCorrectorSheet mempty CorrectorExcused - in Map.insertWith (\_new old -> old) uid (user, Map.singleton shn scr) acc -- keep already known correctors unchanged - ) - - submissions <- E.select . E.from $ \submission -> do - E.where_ $ submission E.^. SubmissionSheet `E.in_` E.valList sheetIds - let numSubmittors = E.subSelectCount . E.from $ \subUser -> - E.where_ $ submission E.^. SubmissionId E.==. subUser E.^. SubmissionUserSubmission - return (submission, numSubmittors) - -- prepare map - let infoMap :: Map SheetName (Map (Maybe UserId) CorrectionInfo) - infoMap = List.foldl (flip buildS) emptySheets submissions - - -- ensure that all sheets are shown, including those without any submissions - emptySheets = foldl (\m sid -> Map.insert (sheetName $ sheets ! sid) emptyCorrs m) Map.empty sheetIds - emptyCorrs = foldl (\m uid -> let cic = Just uid in - Map.insert cic mempty{ciCorrector=cic} m) Map.empty $ Map.keys correctorMap - - - buildS :: (Entity Submission, E.Value Int64) -> Map SheetName (Map (Maybe UserId) CorrectionInfo) -> Map SheetName (Map (Maybe UserId) CorrectionInfo) - buildS (Entity _sheetId Submission{..}, E.Value nrSbmtrs) m = - let shnm = sheetName $ sheets ! submissionSheet - corTime = diffUTCTime <$> submissionRatingTime <*> submissionRatingAssigned - cinf = Map.singleton submissionRatingBy $ CorrectionInfo - { ciSubmittors = fromIntegral nrSbmtrs - , ciSubmissions = 1 - , ciAssigned = maybe 0 (const 1) submissionRatingBy -- only used in sheetMap - , ciCorrected = maybe 0 (const 1) submissionRatingTime - , ciCorrector = submissionRatingBy - , ciMin = corTime - , ciTot = corTime - , ciMax = corTime - } - in Map.insertWith (Map.unionWith (<>)) shnm cinf m - - return (orderedSheetNames, assignSheetNames, nrParticipants, groupsPossible, infoMap, correctorMap, assignment) - - let -- infoMap :: Map SheetName (Map (Maybe UserId) CorrectionInfo) -- repeated here for easier reference - -- create aggregate maps - - -- Always iterate over orderedSheetNames for consistent sorting! - sheetMap :: Map SheetName CorrectionInfo - sheetMap = Map.map fold infoMap - - sheetLoad :: Map SheetName Load - sheetLoad = -- Map.unionsWith (<>) ((Map.filter () ) . snd) <$> Map.elems correctorMap) - let buildSL acc (_user,mSnSc) = Map.foldlWithKey buildL acc mSnSc - buildL acc s SheetCorrector{sheetCorrectorLoad=l, sheetCorrectorState=CorrectorNormal} - = Map.insertWith (<>) s l acc - buildL acc _ _ = acc - in Map.foldl buildSL Map.empty correctorMap - - deficitMap :: Map UserId Rational - deficitMap = foldMap (view _3) assignment - - corrMap :: Map (Maybe UserId) CorrectionInfo - corrMap = Map.unionsWith (<>) $ Map.elems infoMap - - corrInfos :: [CorrectionInfo] - corrInfos = sortBy (compare `on` (byName . ciCorrector) ) $ Map.elems corrMap - where byName Nothing = Nothing - byName (Just uid) = Map.lookup uid correctorMap - corrMapSum :: CorrectionInfo - corrMapSum = fold corrMap - - let -- whamlet convenience functions - -- avoid nestes hamlet $maybe with duplicated $nothing - getCorrector :: Maybe UserId -> (Widget,Map SheetName SheetCorrector, Text) - getCorrector (Just uid) - | Just (User{..},loadMap) <- Map.lookup uid correctorMap - = (nameEmailWidget userEmail userDisplayName userSurname, loadMap, userDisplayName) - -- | Just (User{..} ) <- Map.lookup uid lecturerNames - -- = (nameEmailWidget userEmail userDisplayName userSurname, mempty) -- lecturers may also correct in rare cases - getCorrector _ = ([whamlet|_{MsgNoCorrectorAssigned}|], mempty, mempty) - -- avoid nestes hamlet $maybe with duplicated $nothing - getCorrSheetStatus :: Maybe UserId -> SheetName -> Maybe CorrectionInfo - getCorrSheetStatus corr shn - | (Just smap) <- Map.lookup shn infoMap - = Map.lookup corr smap - getCorrSheetStatus _ _ = Nothing - -- avoid nestes hamlet $maybe with duplicated $nothing - getCorrNewAssignment :: Maybe UserId -> SheetName -> Maybe Int - getCorrNewAssignment corr shn - | (Just (_,cass,_)) <- Map.lookup shn assignment - = Map.lookup corr cass - getCorrNewAssignment _ _ = Nothing - -- avoid nestes hamlet $maybe with duplicated $nothing - getCorrDeficit :: Maybe UserId -> Maybe Rational - getCorrDeficit (Just uid) = Map.lookup uid deficitMap - getCorrDeficit _ = Nothing - - getLoadSum :: SheetName -> Text - getLoadSum shn | (Just load) <- Map.lookup shn sheetLoad - = showCompactCorrectorLoad load CorrectorNormal - getLoadSum _ = mempty - - showDiffDays :: Maybe NominalDiffTime -> Text - showDiffDays = foldMap formatDiffDays - showAvgsDays :: Maybe NominalDiffTime -> Integer -> Text - showAvgsDays Nothing _ = mempty - showAvgsDays (Just dt) n = formatDiffDays $ dt / fromIntegral n - let headingShort - | 0 < Map.size assignment = MsgMenuCorrectionsAssignSheet $ Text.intercalate ", " $ fmap CI.original $ Map.keys assignment - | otherwise = MsgMenuCorrectionsAssign - headingLong = prependCourseTitle tid ssh csh MsgMenuCorrectionsAssign - - unassignableSheets = filter (\shn -> Map.notMember shn assignment) assignSheetNames - unless (null unassignableSheets) $ addMessageI Warning $ MsgSheetsUnassignable $ Text.intercalate ", " $ fmap CI.original unassignableSheets - - siteLayoutMsg headingShort $ do - setTitleI headingLong - $(widgetFile "corrections-overview") - -getCorrectionsDownloadR :: Handler TypedContent -getCorrectionsDownloadR = do -- download all assigned and open submissions - uid <- requireAuthId - subs <- runDB $ selectKeysList - [ SubmissionRatingBy ==. Just uid - , SubmissionRatingTime ==. Nothing - ] [] - when (null subs) $ do - addMessageI Info MsgNoOpenSubmissions - redirect CorrectionsR - submissionMultiArchive SubmissionDownloadAnonymous $ Set.fromList subs diff --git a/src/Handler/Submission/Upload.hs b/src/Handler/Submission/Upload.hs new file mode 100644 index 000000000..6884d97ad --- /dev/null +++ b/src/Handler/Submission/Upload.hs @@ -0,0 +1,50 @@ +module Handler.Submission.Upload + ( getCorrectionsUploadR, postCorrectionsUploadR + ) where + +import Import hiding (link) +-- import System.FilePath (takeFileName) + +import Jobs +import Handler.Utils hiding (colSchool) +import Handler.Utils.Submission + +import qualified Data.Set as Set + +import Data.List (genericLength) + +import qualified Data.Conduit.List as C + + +getCorrectionsUploadR, postCorrectionsUploadR :: Handler Html +getCorrectionsUploadR = postCorrectionsUploadR +postCorrectionsUploadR = do + ((uploadRes, upload), uploadEncoding) <- runFormPost . identifyForm FIDcorrectionsUpload . renderAForm FormStandard $ + areq (zipFileField True Nothing) (fslI MsgCorrUploadField) Nothing + + case uploadRes of + FormMissing -> return () + FormFailure errs -> mapM_ (addMessage Error . toHtml) errs + FormSuccess files -> do + uid <- requireAuthId + mbSubs <- msgSubmissionErrors . runDBJobs . runConduit $ transPipe (lift . lift) files .| C.mapM (either get404 return) .| extractRatingsMsg .| sinkMultiSubmission uid True + case mbSubs of + Nothing -> return () + (Just subs) + | null subs -> addMessageI Warning MsgNoCorrectionsUploaded + | otherwise -> do + subs' <- traverse (\x -> (,) <$> encrypt x <*> encrypt x) $ Set.toList subs :: Handler [(CryptoFileNameSubmission, CryptoUUIDSubmission)] + let trigger = [whamlet|_{MsgCorrectionsUploaded (genericLength subs')}|] + content = Right $(widgetFile "messages/correctionsUploaded") + addMessageModal Success trigger content + + let uploadForm = wrapForm upload def + { formAction = Just $ SomeRoute CorrectionsUploadR + , formEncoding = uploadEncoding + } + + maxUploadMB <- appMaximumContentLength <$> getsYesod appSettings' + + defaultLayout $ do + let uploadInstruction = $(i18nWidgetFile "corrections-upload-instructions") + $(widgetFile "corrections-upload")