Mino

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

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

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