diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index 73f0df665..48d9c5e48 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -550,8 +550,11 @@ postCorrectionR tid ssh csh shn cid = do uid <- requireAuthId void . runDBJobs . runConduit $ transPipe (lift . lift) fileUploads .| extractRatingsMsg .| sinkSubmission uid (Right sub) True + {-case res of + (Left _) -> addMessageI Success MsgRatingFilesUpdated + (Right RatingNotExpected) -> addMessageI Error MsgRatingNotExpected + (Right other) -> throw other-} - addMessageI Success MsgRatingFilesUpdated redirect $ CSubmissionR tid ssh csh shn cid CorrectionR mr <- getMessageRender diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs index c1e2648c5..3d405fff8 100644 --- a/src/Handler/Utils/Submission.hs +++ b/src/Handler/Utils/Submission.hs @@ -3,7 +3,7 @@ module Handler.Utils.Submission , assignSubmissions , submissionBlacklist, filterSubmission, extractRatings, extractRatingsMsg , submissionFileSource, submissionFileQuery - , submissionMultiArchive + , submissionMultiArchive , SubmissionSinkException(..) , sinkSubmission, sinkMultiSubmission , submissionMatchesSheet @@ -142,9 +142,9 @@ assignSubmissions sid restriction = do wholeProps = Map.fromList [ ( sheetCorrectorUser, round $ byProportion * fromInteger lcd ) | Entity _ SheetCorrector{ sheetCorrectorLoad = Load{..}, .. } <- corrsProp ] detQueueLength = fromIntegral (Map.size $ Map.filter (\tuts -> all countsToLoad' tuts) subTutor') - sum deficit detQueue = concat . List.genericReplicate (detQueueLength `div` sum wholeProps) . concatMap (uncurry $ flip List.genericReplicate) $ Map.toList wholeProps - + $logDebugS "assignSubmissions" $ "Deterministic Queue: " <> tshow detQueue - + queue <- liftIO . Rand.evalRandIO . execWriterT $ do tell $ map Just detQueue forever $ @@ -162,11 +162,11 @@ assignSubmissions sid restriction = do maximumDeficit :: (MonadState (_a, _b, Map UserId Integer) m, MonadIO m) => m (Maybe UserId) maximumDeficit = do - transposed <- uses _3 invertMap + transposed <- uses _3 invertMap traverse (liftIO . Rand.evalRandIO . Rand.uniform . snd) (Map.lookupMax transposed) subTutor'' <- liftIO . Rand.evalRandIO . Rand.shuffleM $ Map.toList subTutor' - + subTutor <- fmap (view _1) . flip execStateT (Map.empty, queue, deficit) . forM_ subTutor'' $ \(smid, tuts) -> do let restrictTuts @@ -177,7 +177,7 @@ assignSubmissions sid restriction = do Just q' -> do $logDebugS "assignSubmissions" $ tshow smid <> " -> " <> tshow q' <> " (byDeficit)" assignSubmission False smid q' - Nothing + Nothing | Set.null tuts -> do q <- preuse $ _2 . _head . _Just case q of @@ -194,7 +194,7 @@ assignSubmissions sid restriction = do forM_ (Map.toList subTutor) $ \(smid, tutid) -> update smid [ SubmissionRatingBy =. Just tutid , SubmissionRatingAssigned =. Just now ] - + let assignedSubmissions = Map.keysSet subTutor unassigendSubmissions = Map.keysSet subTutor' \\ assignedSubmissions return (assignedSubmissions, unassigendSubmissions) @@ -222,7 +222,7 @@ submissionMultiArchive (Set.toList -> ids) = do ratedSubmissions <- runDBRunner dbrunner $ do submissions <- selectList [ SubmissionId <-. ids ] [] forM submissions $ \s@(Entity submissionId _) -> maybe (invalidArgs ["Invalid submission numbers"]) (return . (, s)) =<< getRating submissionId - + (<* cleanup) . respondSource "application/zip" . transPipe (runDBRunner dbrunner) $ do let fileEntitySource' :: (Rating, Entity Submission) -> Source (YesodDB UniWorX) File @@ -231,7 +231,7 @@ submissionMultiArchive (Set.toList -> ids) = do let directoryName = Text.unpack $ toPathPiece (cID :: CryptoFileNameSubmission) - + fileEntitySource = do submissionFileSource submissionID =$= Conduit.map entityVal yieldM (ratingFile cID rating) @@ -249,7 +249,7 @@ submissionMultiArchive (Set.toList -> ids) = do } fileEntitySource =$= mapC withinDirectory - + mapM_ fileEntitySource' ratedSubmissions =$= produceZip def =$= Conduit.map toFlushBuilder @@ -374,7 +374,7 @@ sinkSubmission userId mExists isUpdate = do | not (null underlyingFiles) = all (~~ file) [ f | (Entity _ f, Entity _ _sf) <- underlyingFiles ] | otherwise = False undoneDeletion = any submissionFileIsDeletion [ sf | (_, Entity _ sf) <- collidingFiles ] - + when anyChanges $ do touchSubmission when (not $ null collidingFiles) $ @@ -394,14 +394,14 @@ sinkSubmission userId mExists isUpdate = do when undoneDeletion $ do touchSubmission lift $ deleteWhere [ SubmissionFileId <-. [ sfId | (_, Entity sfId sf) <- collidingFiles, submissionFileIsDeletion sf ] ] - + Right (submissionId', r'@Rating'{..}) -> do $logDebugS "sinkSubmission" $ tshow submissionId' unless (submissionId' == submissionId) $ do cID <- encrypt submissionId' throwM $ ForeignRating cID - + alreadySeen <- gets $ getAny . sinkSeenRating when alreadySeen $ throwM DuplicateRating tellSt $ mempty{ sinkSeenRating = Any True } @@ -410,19 +410,20 @@ sinkSubmission userId mExists isUpdate = do Submission{..} <- lift $ getJust submissionId - let anyChanges = or $ + let anyChanges = or $ [ submissionRatingPoints /= ratingPoints , submissionRatingComment /= ratingComment ] -- 'ratingTime' is ignored for consistency with 'File's: - -- + -- -- 'fileModified' is simply stored and never inspected while - -- 'submissionChanged' is always set to @now@. + -- 'submissionChanged' is always set to @now@. when anyChanges $ do Sheet{..} <- lift $ getJust submissionSheet - mapM_ throwM $ validateRating sheetType r' - + --TODO: should display errorMessages + mapM_ throwM $ validateRating sheetType r' + touchSubmission lift $ update submissionId [ SubmissionRatingPoints =. ratingPoints @@ -514,7 +515,7 @@ data SubmissionMultiSinkException { _submissionSinkId :: CryptoFileNameSubmission , _submissionSinkFedFile :: Maybe FilePath , _submissionSinkException :: SubmissionSinkException - } + } deriving (Typeable, Show) instance Exception SubmissionMultiSinkException @@ -522,7 +523,7 @@ instance Exception SubmissionMultiSinkException sinkMultiSubmission :: UserId -> Bool {-^ Are these corrections -} -> Sink SubmissionContent (YesodJobDB UniWorX) (Set SubmissionId) - + -- ^ Expects all supplied 'SubmissionContent' to contain an encrypted 'SubmissionId' and replaces the currently saved files for the respective submissions (either corrected files or original ones, depending on arguments) with the supplied 'SubmissionContent'. -- -- Files that don't occur in the 'SubmissionContent' but are in the database are deleted (or marked as deleted in the case of this being a correction). @@ -545,7 +546,7 @@ sinkMultiSubmission userId isUpdate = do Nothing -> do lift $ do cID <- encrypt sId - $(logDebugS) "sinkMultiSubmission" $ "Doing auth checks for " <> toPathPiece cID + $(logDebugS) "sinkMultiSubmission" $ "Doing auth checks for " <> toPathPiece cID Submission{..} <- get404 sId Sheet{..} <- get404 submissionSheet Course{..} <- get404 sheetCourse @@ -595,7 +596,7 @@ sinkMultiSubmission userId isUpdate = do handleHCError _ e = throwM e handleCryptoID :: CryptoIDError -> _ (Maybe a) handleCryptoID _ = return Nothing - + submissionMatchesSheet :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> DB SubmissionId submissionMatchesSheet tid ssh csh shn cid = do diff --git a/src/Jobs/Queue.hs b/src/Jobs/Queue.hs index 001471544..851b2bf77 100644 --- a/src/Jobs/Queue.hs +++ b/src/Jobs/Queue.hs @@ -46,7 +46,7 @@ writeJobCtlBlock cmd = do return var lift $ writeJobCtl cmd let - removeResVar = HashMap.update (NonEmpty.nonEmpty . NonEmpty.filter (/= resVar)) cmd + removeResVar = HashMap.update (NonEmpty.nonEmpty . NonEmpty.filter (/= resVar)) cmd mExc <- liftIO . atomically $ takeTMVar resVar <* modifyTVar' getResVar removeResVar maybe (return ()) throwM mExc @@ -77,7 +77,8 @@ type YesodJobDB site = ReaderT (YesodPersistBackend site) (WriterT (Set QueuedJo queueDBJob :: Job -> ReaderT (YesodPersistBackend UniWorX) (WriterT (Set QueuedJobId) (HandlerT UniWorX IO)) () queueDBJob job = mapReaderT lift (queueJobUnsafe job) >>= tell . Set.singleton -runDBJobs :: (MonadHandler m, HandlerSite m ~ UniWorX) => ReaderT (YesodPersistBackend UniWorX) (WriterT (Set QueuedJobId) (HandlerT UniWorX IO)) a -> m a +runDBJobs :: (MonadHandler m, HandlerSite m ~ UniWorX) + => ReaderT (YesodPersistBackend UniWorX) (WriterT (Set QueuedJobId) (HandlerT UniWorX IO)) a -> m a runDBJobs act = do (ret, jIds) <- liftHandlerT . runDB $ mapReaderT runWriterT act forM_ jIds $ writeJobCtl . JobCtlPerform