Mino
This commit is contained in:
SJost
parent
a3d22baa5b
commit
b0732ae6c6
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user