module Handler.Utils.Submission ( AssignSubmissionException(..) , assignSubmissions , submissionBlacklist, filterSubmission, extractRatings, extractRatingsMsg , submissionFileSource, submissionFileQuery , submissionMultiArchive , SubmissionSinkException(..) , msgSubmissionErrors -- wrap around sinkSubmission/sinkMultiSubmission, but outside of runDB! , sinkSubmission, sinkMultiSubmission , submissionMatchesSheet , submissionDeleteRoute ) where import Import hiding (joinPath) import Jobs.Queue import Prelude (lcm) import Yesod.Core.Types (HandlerContents(..), ErrorResponse(..)) import Utils.Lens import Control.Monad.State hiding (forM_, mapM_,foldM) import Control.Monad.Writer (MonadWriter(..), execWriterT, execWriter) import Control.Monad.RWS.Lazy (RWST) import qualified Control.Monad.Random as Rand import qualified System.Random.Shuffle as Rand (shuffleM) import Data.Maybe () import qualified Data.List as List import Data.Set (Set) import qualified Data.Set as Set import Data.Map (Map) import qualified Data.Map as Map import qualified Data.Text as Text import Data.Ratio import Data.Monoid (Monoid, Any(..), Sum(..)) import Generics.Deriving.Monoid (memptydefault, mappenddefault) import Handler.Utils import qualified Handler.Utils.Rating as Rating (extractRatings) import Handler.Utils.Delete import qualified Database.Esqueleto as E import qualified Database.Esqueleto.Utils.TH as E import qualified Data.Conduit.List as Conduit import Data.Conduit.ResumableSink import System.FilePath import System.FilePath.Glob import Text.Hamlet (ihamletFile) import qualified Control.Monad.Catch as E (Handler(..)) data AssignSubmissionException = NoCorrectorsByProportion deriving (Typeable, Show) instance Exception AssignSubmissionException -- | Assigns all submissions according to sheet corrector loads assignSubmissions :: SheetId -- ^ Sheet do distribute to correction -> Maybe (Set SubmissionId) -- ^ Optionally restrict submission to consider -> YesodDB UniWorX ( Set SubmissionId , Set SubmissionId ) -- ^ Returns assigned and unassigned submissions; unassigned submissions occur only if no tutors have an assigned load assignSubmissions sid restriction = do Sheet{..} <- getJust sid correctors <- selectList [ SheetCorrectorSheet ==. sid, SheetCorrectorState ==. CorrectorNormal ] [] let -- byTutorial' uid = join . Map.lookup uid $ Map.fromList [ (sheetCorrectorUser, byTutorial sheetCorrectorLoad) | Entity _ SheetCorrector{..} <- corrsTutorial ] corrsTutorial = filter hasTutorialLoad correctors -- needed as List within Esqueleto corrsProp = filter hasPositiveLoad correctors countsToLoad' :: UserId -> Bool countsToLoad' uid = Map.findWithDefault True uid loadMap loadMap :: Map UserId Bool loadMap = Map.fromList [(sheetCorrectorUser,b) | Entity _ SheetCorrector{ sheetCorrectorLoad = (Load {byTutorial = Just b}), .. } <- corrsTutorial] currentSubs <- E.select . E.from $ \(submission `E.LeftOuterJoin` tutor') -> do let tutors = E.subList_select . E.from $ \(submissionUser `E.InnerJoin` tutorialUser `E.InnerJoin` tutorial `E.InnerJoin` tutor) -> do -- Uncomment next line for equal chance between tutors, irrespective of the number of students per tutor per submission group -- E.distinctOn [E.don $ tutorial E.^. TutorialTutor] $ do E.on (tutorial E.^. TutorialId E.==. tutor E.^. TutorTutorial) E.on (tutorial E.^. TutorialId E.==. tutorialUser E.^. TutorialParticipantTutorial) E.on (submissionUser E.^. SubmissionUserUser E.==. tutorialUser E.^. TutorialParticipantUser) E.where_ (tutor E.^. TutorUser `E.in_` E.valList (map (sheetCorrectorUser . entityVal) corrsTutorial)) return $ tutor E.^. TutorUser E.on $ tutor' E.?. UserId `E.in_` E.justList tutors E.where_ $ submission E.^. SubmissionSheet E.==. E.val sid E.&&. maybe (E.val True) (submission E.^. SubmissionId `E.in_`) (E.valList . Set.toList <$> restriction) return (submission E.^. SubmissionId, tutor' E.?. UserId) let subTutor' :: Map SubmissionId (Set UserId) subTutor' = Map.fromListWith Set.union $ currentSubs & mapped._2 %~ (maybe Set.empty Set.singleton . E.unValue) & mapped._1 %~ E.unValue prevSubs <- E.select . E.from $ \((sheet `E.InnerJoin` sheetCorrector) `E.LeftOuterJoin` submission) -> do E.on $ E.joinV (submission E.?. SubmissionRatingBy) E.==. E.just (sheetCorrector E.^. SheetCorrectorUser) E.on $ sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId let isByTutorial = E.exists . E.from $ \(submissionUser `E.InnerJoin` tutorialUser `E.InnerJoin` tutorial `E.InnerJoin` tutor) -> do E.on (tutorial E.^. TutorialId E.==. tutor E.^. TutorTutorial) E.on $ tutorial E.^. TutorialId E.==. tutorialUser E.^. TutorialParticipantTutorial E.on $ submissionUser E.^. SubmissionUserUser E.==. tutorialUser E.^. TutorialParticipantUser E.where_ $ tutor E.^. TutorUser E.==. sheetCorrector E.^. SheetCorrectorUser E.&&. submission E.?. SubmissionId E.==. E.just (submissionUser E.^. SubmissionUserSubmission) E.where_ $ sheet E.^. SheetCourse E.==. E.val sheetCourse E.&&. sheetCorrector E.^. SheetCorrectorUser `E.in_` E.valList (map (sheetCorrectorUser . entityVal) correctors) return (sheetCorrector, isByTutorial, E.isNothing (submission E.?. SubmissionId)) let prevSubs' :: Map SheetId (Map UserId (Rational, Integer)) prevSubs' = Map.unionsWith (Map.unionWith $ \(prop, n) (_, n') -> (prop, n + n')) $ do (Entity _ SheetCorrector{ sheetCorrectorLoad = Load{..}, .. }, E.Value isByTutorial, E.Value isPlaceholder) <- prevSubs guard $ maybe True (not isByTutorial ||) byTutorial let proportion | CorrectorExcused <- sheetCorrectorState = 0 | otherwise = byProportion return . Map.singleton sheetCorrectorSheet $ Map.singleton sheetCorrectorUser (proportion, bool 1 0 isPlaceholder) deficit :: Map UserId Integer deficit = Map.filter (> 0) $ Map.foldr (Map.unionWith (+) . toDeficit) Map.empty prevSubs' toDeficit :: Map UserId (Rational, Integer) -> Map UserId Integer toDeficit assignments = toDeficit' <$> assignments where assigned' = getSum $ foldMap (Sum . snd) assignments props = getSum $ foldMap (Sum . fst) assignments toDeficit' (prop, assigned) = let target | props == 0 = 0 | otherwise = round $ fromInteger assigned' * (prop / props) in target - assigned $logDebugS "assignSubmissions" $ "Previous submissions: " <> tshow prevSubs' $logDebugS "assignSubmissions" $ "Current deficit: " <> tshow deficit let lcd :: Integer lcd = foldr lcm 1 $ map (denominator . byProportion . sheetCorrectorLoad . entityVal) corrsProp wholeProps :: Map UserId Integer 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 $ tell . pure =<< Rand.weightedMay [ (sheetCorrectorUser, byProportion sheetCorrectorLoad) | Entity _ SheetCorrector{..} <- corrsProp ] $logDebugS "assignSubmissions" $ "Queue: " <> tshow (take (Map.size subTutor') queue) let assignSubmission :: MonadState (Map SubmissionId UserId, [Maybe UserId], Map UserId Integer) m => Bool -> SubmissionId -> UserId -> m () assignSubmission countsToLoad smid tutid = do _1 %= Map.insert smid tutid _3 . at tutid %= assertM' (> 0) . maybe (-1) pred when countsToLoad $ _2 %= List.delete (Just tutid) maximumDeficit :: (MonadState (_a, _b, Map UserId Integer) m, MonadIO m) => m (Maybe UserId) maximumDeficit = do 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 | Set.null tuts = id | otherwise = flip Map.restrictKeys tuts byDeficit <- withStateT (over _3 restrictTuts) maximumDeficit case byDeficit of Just q' -> do $logDebugS "assignSubmissions" $ tshow smid <> " -> " <> tshow q' <> " (byDeficit)" assignSubmission False smid q' Nothing | Set.null tuts -> do q <- preuse $ _2 . _head . _Just case q of Just q' -> do $logDebugS "assignSubmissions" $ tshow smid <> " -> " <> tshow q' <> " (queue)" assignSubmission True smid q' Nothing -> return () | otherwise -> do q <- liftIO . Rand.evalRandIO $ Rand.uniform tuts $logDebugS "assignSubmissions" $ tshow smid <> " -> " <> tshow q <> " (tutorial)" assignSubmission (countsToLoad' q) smid q now <- liftIO getCurrentTime 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) where hasPositiveLoad = (> 0) . byProportion . sheetCorrectorLoad . entityVal hasTutorialLoad = isJust . byTutorial . sheetCorrectorLoad . entityVal submissionFileSource :: SubmissionId -> Source (YesodDB UniWorX) (Entity File) submissionFileSource = E.selectSource . fmap snd . E.from . submissionFileQuery submissionFileQuery :: SubmissionId -> E.SqlExpr (Entity SubmissionFile) `E.InnerJoin` E.SqlExpr (Entity File) -> E.SqlQuery (E.SqlExpr (Entity SubmissionFile), E.SqlExpr (Entity File)) submissionFileQuery submissionID (sf `E.InnerJoin` f) = E.distinctOnOrderBy [E.asc $ f E.^. FileTitle] $ do E.on (f E.^. FileId E.==. sf E.^. SubmissionFileFile) E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionID E.where_ . E.not_ $ sf E.^. SubmissionFileIsDeletion -- TODO@gk: won't work as intended! Fix with refactor E.orderBy [E.desc $ sf E.^. SubmissionFileIsUpdate] -- E.desc returns corrector updated data first return (sf, f) submissionMultiArchive :: Set SubmissionId -> Handler TypedContent submissionMultiArchive (Set.toList -> ids) = do (dbrunner, cleanup) <- getDBRunner ratedSubmissions <- runDBRunner dbrunner $ do submissions <- E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` submission) -> do E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId E.where_ $ submission E.^. SubmissionId `E.in_` E.valList ids return (submission, (sheet E.^. SheetName, course E.^. CourseShorthand, course E.^. CourseSchool, course E.^. CourseTerm)) forM submissions $ \(s@(Entity submissionId _), courseSheetInfo) -> maybe (invalidArgs ["Invalid submission numbers"]) (return . (, s, $(E.unValueN 4) courseSheetInfo)) =<< getRating submissionId let (setSheet,setCourse,setSchool,setTerm) = execWriter . forM ratedSubmissions $ \(_rating,_submission,(shn,csh,ssh,tid)) -> tell (Set.singleton shn, Set.singleton csh, Set.singleton ssh, Set.singleton tid) (<* cleanup) . respondSource "application/zip" . transPipe (runDBRunner dbrunner) $ do let fileEntitySource' :: (Rating, Entity Submission, (SheetName,CourseShorthand,SchoolId,TermId)) -> Source (YesodDB UniWorX) File fileEntitySource' (rating, Entity submissionID Submission{..},(shn,csh,ssh,tid)) = do cID <- encrypt submissionID let dirFrag :: PathPiece p => p -> FilePath dirFrag = Text.unpack . toPathPiece submissionDirectory = dirFrag (cID :: CryptoFileNameSubmission) directoryName | Set.size setTerm > 1 = dirFrag tid dirFrag ssh dirFrag csh dirFrag shn submissionDirectory | Set.size setSchool > 1 = dirFrag ssh dirFrag csh dirFrag shn submissionDirectory | Set.size setCourse > 1 = dirFrag csh dirFrag shn submissionDirectory | Set.size setSheet > 1 = dirFrag shn submissionDirectory | otherwise = submissionDirectory fileEntitySource = do submissionFileSource submissionID =$= Conduit.map entityVal yieldM (ratingFile cID rating) withinDirectory f@File{..} = f { fileTitle = directoryName fileTitle } lastEditMb <- lift $ selectList [SubmissionEditSubmission ==. submissionID] [Desc SubmissionEditTime, LimitTo 1] lastEditTime <- case lastEditMb of [(submissionEditTime.entityVal -> time)] -> return time _other -> liftIO getCurrentTime yield $ File { fileModified = lastEditTime , fileTitle = directoryName , fileContent = Nothing } fileEntitySource =$= mapC withinDirectory mapM_ fileEntitySource' ratedSubmissions =$= produceZip def =$= Conduit.map toFlushBuilder data SubmissionSinkState = SubmissionSinkState { sinkSeenRating :: Any , sinkSubmissionTouched :: Any , sinkSubmissionNotifyRating :: Any , sinkFilenames :: Set FilePath } deriving (Show, Eq, Generic, Typeable) instance Monoid SubmissionSinkState where mempty = memptydefault mappend = mappenddefault filterSubmission :: MonadLogger m => ConduitM File File m (Set FilePath) -- ^ Removes all `File`s matching `submissionBlacklist`, returning their `fileTitle`s filterSubmission = do $logDebugS "filterSubmission" $ tshow submissionBlacklist execWriterLC . awaitForever $ \case File{fileTitle} | any (`match'` fileTitle) submissionBlacklist -> tell $ Set.singleton fileTitle file -> yield file where match' = matchWith $ matchDefault { matchDotsImplicitly = True -- Special treatment for . makes no sense since we're multiplatform } extractRatings :: ( MonadHandler m , HandlerSite m ~ UniWorX , MonadCatch m , MonadLogger m ) => ConduitM File SubmissionContent m (Set FilePath) extractRatings = filterSubmission `fuseUpstream` Rating.extractRatings extractRatingsMsg :: ( MonadHandler m , HandlerSite m ~ UniWorX , MonadCatch m , MonadLogger m ) => Conduit File m SubmissionContent extractRatingsMsg = do ignored' <- filterSubmission `fuseUpstream` Rating.extractRatings let ignoredFiles :: Set (Either CryptoFileNameSubmission FilePath) ignoredFiles = Right `Set.map` ignored' unless (null ignoredFiles) $ do let ignoredModal = msgModal [whamlet|_{MsgSubmissionFilesIgnored (Set.size ignoredFiles)}|] (Right $(widgetFile "messages/submissionFilesIgnored")) addMessageWidget Warning ignoredModal -- Nicht innerhalb von runDB aufrufen, damit das DB Rollback passieren kann! msgSubmissionErrors :: (MonadHandler m, MonadCatch m, HandlerSite m ~ UniWorX) => m a -> m (Maybe a) msgSubmissionErrors = flip catches [ E.Handler $ \e -> Nothing <$ addMessageI Error (e :: RatingException) , E.Handler $ \e -> Nothing <$ addMessageI Error (e :: SubmissionSinkException) , E.Handler $ \(SubmissionSinkException sinkId _ sinkEx) -> do mr <- getMessageRender addMessageI Error $ MsgMultiSinkException (toPathPiece sinkId) (mr sinkEx) return Nothing ] . fmap Just sinkSubmission :: UserId -> Either SheetId SubmissionId -> Bool -- ^ Is this a correction -> Sink SubmissionContent (YesodJobDB UniWorX) SubmissionId -- ^ Replace the currently saved files for the given submission (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). -- -- A 'Submission' is created if no 'SubmissionId' is supplied sinkSubmission userId mExists isUpdate = do sId <- lift $ case mExists of Left sheetId -> do let submissionSheet = sheetId submissionRatingPoints = Nothing submissionRatingComment = Nothing submissionRatingBy = Nothing submissionRatingAssigned = Nothing submissionRatingTime = Nothing sId <- insert Submission{..} -- now <- liftIO getCurrentTime -- insert $ SubmissionEdit userId now sId -- This is done automatically during 'sinkSubmission'' iff the given submission is nonempty return sId Right sId -> return sId Sheet{..} <- lift $ case mExists of Left sheetId -> getJust sheetId Right subId -> getJust . submissionSheet =<< getJust subId sId <$ (guardFileTitles sheetSubmissionMode .| sinkSubmission' sId) where tellSt = modify . mappend guardFileTitles :: MonadThrow m => SubmissionMode -> Conduit SubmissionContent m SubmissionContent guardFileTitles SubmissionMode{..} | Just UploadAny{..} <- submissionModeUser , not isUpdate , Just (map unpack . Set.toList . toNullable -> exts) <- extensionRestriction = Conduit.mapM $ \x -> if | Left File{..} <- x , none (`isExtensionOf` fileTitle) exts , isn't _Nothing fileContent -- File record is not a directory, we don't care about those -> throwM $ InvalidFileTitleExtension fileTitle | otherwise -> return x | otherwise = Conduit.map id sinkSubmission' :: SubmissionId -> Sink SubmissionContent (YesodJobDB UniWorX) () sinkSubmission' submissionId = lift . finalize <=< execStateLC mempty . Conduit.mapM_ $ \case Left file@(File{..}) -> do $logDebugS "sinkSubmission" . tshow $ (submissionId, fileTitle) alreadySeen <- gets (Set.member fileTitle . sinkFilenames) when alreadySeen . throwM $ DuplicateFileTitle fileTitle tellSt $ mempty{ sinkFilenames = Set.singleton fileTitle } otherVersions <- lift . E.select . E.from $ \(sf `E.InnerJoin` f) -> do E.on $ sf E.^. SubmissionFileFile E.==. f E.^. FileId E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionId -- E.where_ $ sf E.^. SubmissionFileIsUpdate E.==. E.val isUpdate E.where_ $ f E.^. FileTitle E.==. E.val fileTitle -- 'Zip.hs' normalises filenames already, so this should work return (f, sf) let collidingFiles = [ t | t@(_, Entity _ sf) <- otherVersions , submissionFileIsUpdate sf == isUpdate ] underlyingFiles = [ t | t@(_, Entity _ sf) <- otherVersions , submissionFileIsUpdate sf == False ] anyChanges | not (null collidingFiles) = any (/~ file) [ f | (Entity _ f, _) <- collidingFiles ] | otherwise = True matchesUnderlying | 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) $ lift $ deleteCascadeWhere [ FileId <-. [ fId | (Entity fId _, _) <- collidingFiles ] ] lift $ case () of _ | matchesUnderlying , isUpdate -> return () _ -> do fileId <- insert file insert_ $ SubmissionFile { submissionFileSubmission = submissionId , submissionFileFile = fileId , submissionFileIsUpdate = isUpdate , submissionFileIsDeletion = False } 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 } unless isUpdate $ throwM RatingWithoutUpdate Submission{..} <- lift $ getJust submissionId 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@. when anyChanges $ do Sheet{..} <- lift $ getJust submissionSheet --TODO: should display errorMessages mapM_ throwM $ validateRating sheetType r' touchSubmission lift $ update submissionId [ SubmissionRatingPoints =. ratingPoints , SubmissionRatingComment =. ratingComment ] where a /~ b = not $ a ~~ b (~~) :: File -> File -> Bool (~~) a b | isUpdate = fileTitle a == fileTitle b && fileContent a == fileContent b | otherwise = a == b -- The Eq Instance for File compares modification time exactly even -- though zip archives have very limited accuracy and range regarding -- timestamps. -- We thus expect to replace files a little more often than is actually -- necessary. -- This was done on the premise that changes in file modification time -- break file identity under upload and re-download. -- -- The check whether the new version matches the underlying file is -- more lenient, considering only filename and -content. touchSubmission :: StateT SubmissionSinkState (YesodJobDB UniWorX) () touchSubmission = do alreadyTouched <- gets $ getAny . sinkSubmissionTouched when (not alreadyTouched) $ do now <- liftIO getCurrentTime case isUpdate of False -> lift . insert_ $ SubmissionEdit userId now submissionId True -> do Submission{submissionRatingTime, submissionRatingBy} <- lift $ getJust submissionId when (submissionRatingBy == Just userId) $ do when (isNothing submissionRatingTime) $ tellSt mempty { sinkSubmissionNotifyRating = Any True } lift $ update submissionId [ SubmissionRatingTime =. Just now ] tellSt $ mempty{ sinkSubmissionTouched = Any True } finalize :: SubmissionSinkState -> YesodJobDB UniWorX () finalize SubmissionSinkState{..} = do missingFiles <- E.select . E.from $ \(sf `E.InnerJoin` f) -> E.distinctOnOrderBy [E.asc $ f E.^. FileTitle] $ do E.on $ sf E.^. SubmissionFileFile E.==. f E.^. FileId E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionId when (not isUpdate) $ E.where_ $ sf E.^. SubmissionFileIsUpdate E.==. E.val isUpdate E.where_ $ f E.^. FileTitle `E.notIn` E.valList (Set.toList sinkFilenames) E.orderBy [E.desc $ sf E.^. SubmissionFileIsUpdate] return (f, sf) case isUpdate of False -> deleteCascadeWhere [ FileId <-. [ fileId | (Entity fileId _, _) <- missingFiles ] ] True -> forM_ missingFiles $ \(Entity fileId File{..}, Entity sfId SubmissionFile{..}) -> do shadowing <- E.select . E.from $ \(sf `E.InnerJoin` f) -> do E.on $ sf E.^. SubmissionFileFile E.==. f E.^. FileId E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionId E.where_ $ sf E.^. SubmissionFileIsUpdate E.==. E.val (not isUpdate) E.where_ $ f E.^. FileTitle E.==. E.val fileTitle return $ f E.^. FileId case (shadowing, submissionFileIsUpdate) of ([], _) -> deleteCascade fileId (E.Value f:_, False) -> do insert_ $ SubmissionFile { submissionFileSubmission = submissionId , submissionFileFile = f , submissionFileIsUpdate = True , submissionFileIsDeletion = True } (E.Value f:_, True) -> do update sfId [ SubmissionFileFile =. f, SubmissionFileIsDeletion =. True ] deleteCascade fileId if | isUpdate , not $ getAny sinkSeenRating -> update submissionId [ SubmissionRatingTime =. Nothing , SubmissionRatingPoints =. Nothing , SubmissionRatingComment =. Nothing ] | isUpdate , getAny sinkSubmissionNotifyRating -> queueDBJob . JobQueueNotification $ NotificationSubmissionRated submissionId | otherwise -> return () 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). -- -- In contrast to `sinkSubmission` this function does authorization-checks against `CorrectionR` sinkMultiSubmission userId isUpdate = do let feed :: SubmissionId -> SubmissionContent -> RWST () _ (Map SubmissionId (ResumableSink SubmissionContent (YesodJobDB UniWorX) SubmissionId)) (YesodJobDB UniWorX) () feed sId val = do mSink <- gets $ Map.lookup sId sink <- case mSink of Just sink -> return sink Nothing -> do lift $ do cID <- encrypt sId $(logDebugS) "sinkMultiSubmission" $ "Doing auth checks for " <> toPathPiece cID Submission{..} <- get404 sId Sheet{..} <- get404 submissionSheet Course{..} <- get404 sheetCourse guardAuthResult =<< evalAccessDB (CSubmissionR courseTerm courseSchool courseShorthand sheetName cID CorrectionR) True return . newResumableSink $ sinkSubmission userId (Right sId) isUpdate sink' <- lift $ yield val ++$$ sink case sink' of Left _ -> error "sinkSubmission returned prematurely" Right nSink -> modify $ Map.insert sId nSink (sinks, ignoredFiles) <- execRWSLC () Map.empty . awaitForever $ \case v@(Right (sId, _)) -> do cID <- encrypt sId $logDebugS "sinkMultiSubmission" $ "Feeding rating for " <> toPathPiece cID lift (feed sId v) `catches` [ E.Handler (throwM . SubmissionSinkException cID Nothing), E.Handler (void . handleHCError (Left cID)) ] (Left f@File{..}) -> do let acc :: (Maybe SubmissionId, [FilePath]) -> FilePath -> _ (Maybe SubmissionId, [FilePath]) acc (Just sId, fp) segment = return (Just sId, fp ++ [segment]) acc (Nothing , fp) segment = do let tryDecrypt (Text.pack -> ciphertext) | Just cID <- fromPathPiece ciphertext = do sId <- decrypt (cID :: CryptoFileNameSubmission) Just sId <$ get404 sId | otherwise = return Nothing msId <- lift (lift $ tryDecrypt segment) `catches` [ E.Handler handleCryptoID, E.Handler (handleHCError $ Right fileTitle) ] return (msId, fp) (msId, (joinPath -> fileTitle')) <- foldM acc (Nothing, []) $ splitDirectories fileTitle case msId of Nothing -> do $logDebugS "sinkMultiSubmission" $ "Dropping " <> tshow (splitDirectories fileTitle, msId, fileTitle') Just sId -> do $logDebugS "sinkMultiSubmission" $ "Feeding " <> tshow (splitDirectories fileTitle, msId, fileTitle') cID <- encrypt sId handle (throwM . SubmissionSinkException cID (Just fileTitle)) $ lift . feed sId $ Left f{ fileTitle = fileTitle' } when (not $ null ignoredFiles) $ do mr <- (toHtml .) <$> getMessageRender addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionFilesIgnored.hamlet") mr) lift . fmap Set.fromList . forM (Map.toList sinks) $ \(sId, sink) -> do cID <- encrypt sId handle (throwM . SubmissionSinkException cID Nothing) $ closeResumableSink sink where handleHCError :: Either CryptoFileNameSubmission FilePath -> HandlerContents -> _ (Maybe a) handleHCError ident (HCError NotFound) = Nothing <$ tell (Set.singleton ident) 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 sid <- decrypt cid shid <- fetchSheetId tid ssh csh shn Submission{..} <- get404 sid when (shid /= submissionSheet) $ invalidArgsI [MsgSubmissionWrongSheet] return sid submissionDeleteRoute :: Set SubmissionId -> DeleteRoute Submission submissionDeleteRoute drRecords = DeleteRoute { drRecords , drUnjoin = \(submission `E.InnerJoin` _ `E.InnerJoin` _ `E.InnerJoin` _) -> submission , drGetInfo = \(submission `E.InnerJoin` sheet `E.InnerJoin` course `E.InnerJoin` school) -> do E.on $ school E.^. SchoolId E.==. course E.^. CourseSchool E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet let lastEdit = E.sub_select . E.from $ \submissionEdit -> do E.where_ $ submissionEdit E.^. SubmissionEditSubmission E.==. submission E.^. SubmissionId return . E.max_ $ submissionEdit E.^. SubmissionEditTime E.orderBy [E.desc lastEdit] return (submission E.^. SubmissionId, sheet E.^. SheetName, course E.^. CourseShorthand, course E.^. CourseName, school E.^. SchoolShorthand, school E.^. SchoolName, course E.^. CourseTerm) , drRenderRecord = \(E.Value subId', E.Value shn', _, E.Value cName, _, E.Value sName, E.Value tid') -> do subUsers <- selectList [SubmissionUserSubmission ==. subId'] [] subNames <- fmap (sortOn snd) . forM subUsers $ \(Entity _ SubmissionUser{submissionUserUser}) -> (userDisplayName &&& userSurname) <$> getJust submissionUserUser return [whamlet| $newline never