module Handler.Utils.Submission ( AssignSubmissionException(..) , assignSubmissions, writeSubmissionPlan, planSubmissions , 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 Yesod.Core.Types (HandlerContents(..)) import Control.Monad.State.Class as State import Control.Monad.RWS.Lazy (MonadRWS, RWST, execRWST) import qualified Control.Monad.Random as Rand import Data.Maybe () import qualified Data.Set as Set import Data.Map ((!), (!?)) import qualified Data.Map as Map import qualified Data.Text as Text 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(..)) import qualified Data.CaseInsensitive as CI import Text.Unidecode (unidecode) import Data.Char (isAlphaNum) data AssignSubmissionException = NoCorrectors | NoCorrectorsByProportion | SubmissionsNotFound (NonNull (Set SubmissionId)) deriving (Eq, Ord, Read, Show, Generic, Typeable) instance Exception AssignSubmissionException -- | Assigns all submissions according to sheet corrector loads assignSubmissions :: SheetId -- ^ Sheet to distribute to correctors -> 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 (plan,_) <- planSubmissions sid restriction writeSubmissionPlan plan -- | Assigns all submissions according to an already given assignment plan writeSubmissionPlan :: Map SubmissionId (Maybe UserId) -- ^ map that assigns submissions to correctors -> YesodDB UniWorX ( Set SubmissionId , Set SubmissionId ) -- ^ Returns assigned and unassigned submissions; unassigned submissions occur only if no tutors have an assigned load writeSubmissionPlan newSubmissionData = do now <- liftIO getCurrentTime execWriterT . forM_ (Map.toList newSubmissionData) $ \(subId, mCorrector) -> if | is _Just mCorrector -> do lift $ do Submission{submissionSheet} <- updateGet subId [ SubmissionRatingBy =. mCorrector , SubmissionRatingAssigned =. Just now ] audit $ TransactionSubmissionEdit subId submissionSheet tell (Set.singleton subId, mempty) | otherwise -> tell (mempty, Set.singleton subId) -- | Compute a map that shows which submissions ought the be assigned to each corrector according to sheet corrector loads, but does not alter database yet! -- May throw an exception if there are no suitable correctors planSubmissions :: SheetId -- ^ Sheet to distribute to correctors -> Maybe (Set SubmissionId) -- ^ Optionally restrict submission to consider -> YesodDB UniWorX (Map SubmissionId (Maybe UserId), Map UserId Rational) -- ^ Return map that assigns submissions to Corrector and another map showing each current correctors _previous_ deficit planSubmissions sid restriction = do Sheet{..} <- getJust sid correctorsRaw <- E.select . E.from $ \(sheet `E.InnerJoin` sheetCorrector) -> do E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet E.where_ $ sheetCorrector E.^. SheetCorrectorState `E.in_` E.valList [CorrectorNormal, CorrectorMissing] return (sheet E.^. SheetId, sheetCorrector) let correctors :: Map SheetId (Map UserId (Load, CorrectorState)) correctors = Map.fromList $ do E.Value sheetId <- Set.toList $ setOf (folded . _1) correctorsRaw let loads = Map.fromList $ do (E.Value sheetId', Entity _ SheetCorrector{..}) <- correctorsRaw guard $ sheetId' == sheetId return (sheetCorrectorUser, (sheetCorrectorLoad, sheetCorrectorState)) return (sheetId, loads) sheetCorrectors :: Map UserId Load sheetCorrectors = Map.mapMaybe filterLoad $ correctors ! sid where filterLoad (l@Load{..}, CorrectorNormal) = l <$ guard (isJust byTutorial || byProportion /= 0) filterLoad _ = Nothing unless (Map.member sid correctors) $ throwM NoCorrectors submissionDataRaw <- E.select . E.from $ \((sheet `E.InnerJoin` submission `E.InnerJoin` submissionUser) `E.LeftOuterJoin` (tutorial `E.InnerJoin` tutorialUser `E.InnerJoin` tutor)) -> do E.on $ tutor E.?. TutorTutorial E.==. tutorial E.?. TutorialId E.on $ tutorialUser E.?. TutorialParticipantTutorial E.==. tutorial E.?. TutorialId E.on $ tutorialUser E.?. TutorialParticipantUser E.==. E.just (submissionUser E.^. SubmissionUserUser) E.&&. tutor E.?. TutorUser `E.in_` E.justList (E.valList $ foldMap Map.keys correctors) E.&&. tutorial E.?. TutorialCourse E.==. E.just (E.val sheetCourse) E.on $ submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission E.on $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId E.where_ $ sheet E.^. SheetCourse E.==. E.val sheetCourse return (sheet E.^. SheetId, submission, tutor E.?. TutorUser) let -- | All submissions in this course so far submissionData :: Map SubmissionId ( Maybe UserId -- Corrector , Map UserId (Sum Natural) -- Tutors , SheetId ) submissionData = Map.fromListWith merge $ map process submissionDataRaw where process (E.Value sheetId, Entity subId Submission{..}, E.Value mTutId) = (subId, (submissionRatingBy, maybe Map.empty (flip Map.singleton $ Sum 1) $ assertM isCorrectorByTutorial mTutId, sheetId)) merge (corrA, tutorsA, sheetA) (corrB, tutorsB, sheetB) | corrA /= corrB = error "Same submission seen with different correctors" | sheetA /= sheetB = error "Same submission seen with different sheets" | otherwise = (corrA, Map.unionWith mappend tutorsA tutorsB, sheetA) -- Not done in esqueleto, since inspection of `Load`-Values is difficult isCorrectorByTutorial = maybe False (\Load{..} -> is _Just byTutorial) . flip Map.lookup sheetCorrectors targetSubmissions = Set.fromList $ do (E.Value sheetId, Entity subId Submission{..}, _) <- submissionDataRaw guard $ sheetId == sid case restriction of Just restriction' -> guard $ subId `Set.member` restriction' Nothing -> guard $ is _Nothing submissionRatingBy return subId targetSubmissionData = set _1 Nothing <$> Map.restrictKeys submissionData targetSubmissions oldSubmissionData = Map.withoutKeys submissionData targetSubmissions whenIsJust (fromNullable =<< fmap (`Set.difference` targetSubmissions) restriction) $ \missing -> throwM $ SubmissionsNotFound missing let withSubmissionData :: MonadRWS (Map SubmissionId a) w (Map SubmissionId a) m => (Map SubmissionId a -> b) -> m b withSubmissionData f = f <$> (mappend <$> ask <*> State.get) -- | Old Deficit for protocol purposes, not used here oldDeficit :: Map UserId Rational oldDeficit = Map.mapWithKey (\k _v -> calculateDeficit k submissionData) sheetCorrectors -- | How many additional submission should the given corrector be assigned, if possible? calculateDeficit :: UserId -> Map SubmissionId (Maybe UserId, Map UserId _, SheetId) -> Rational calculateDeficit corrector submissionState = getSum $ foldMap Sum deficitBySheet where sheetSizes :: Map SheetId Integer -- ^ Number of assigned submissions (to anyone) per sheet sheetSizes = Map.map getSum . Map.fromListWith mappend $ do (_, (Just _, _, sheetId)) <- Map.toList submissionState return (sheetId, Sum 1) deficitBySheet :: Map SheetId Rational -- ^ Deficite of @corrector@ per sheet deficitBySheet = flip Map.mapMaybeWithKey sheetSizes $ \sheetId sheetSize -> do let assigned :: Rational assigned = fromIntegral . Map.size $ Map.filter (\(mCorr, _, sheetId') -> mCorr == Just corrector && sheetId == sheetId') submissionState proportionSum :: Rational proportionSum = getSum . foldMap corrProportion . fromMaybe Map.empty $ correctors !? sheetId where corrProportion (_, CorrectorExcused) = mempty corrProportion (Load{..}, _) = Sum byProportion relativeProportion :: Rational -> Rational relativeProportion prop | proportionSum == 0 = 0 | otherwise = prop / proportionSum extra | Just (Load{..}, corrState) <- correctors !? sheetId >>= Map.lookup corrector = sum [ assigned , fromMaybe 0 $ do -- If corrections assigned by tutorial do not count against proportion, substract them from deficit tutCounts <- byTutorial guard $ not tutCounts guard $ corrState /= CorrectorExcused return . negate . fromIntegral . Map.size $ Map.filter (\(mCorr, tutors, sheetId') -> mCorr == Just corrector && sheetId == sheetId' && Map.member corrector tutors) submissionState , fromMaybe 0 $ do guard $ corrState /= CorrectorExcused return . negate $ relativeProportion byProportion * fromIntegral sheetSize ] | otherwise = assigned return $ negate extra -- Sort target submissions by those that have tutors first and otherwise random -- -- Deficit produced by restriction to tutors can thus be fixed by later submissions targetSubmissions' <- liftIO . unstableSortBy (comparing $ \subId -> Map.null . view _2 $ submissionData ! subId) $ Set.toList targetSubmissions (newSubmissionData, ()) <- (\act -> execRWST act oldSubmissionData targetSubmissionData) . forM_ (zip [1..] targetSubmissions') $ \(i, subId) -> do tutors <- gets $ view _2 . (! subId) -- :: Map UserId (Sum Natural) let acceptableCorrectors | correctorsByTut <- Map.filter (is _Just . view _byTutorial) $ sheetCorrectors `Map.restrictKeys` Map.keysSet tutors , not $ null correctorsByTut = Map.keysSet correctorsByTut | otherwise = Map.keysSet $ Map.filter (views _byProportion (/= 0)) sheetCorrectors when (not $ null acceptableCorrectors) $ do deficits <- sequence . flip Map.fromSet acceptableCorrectors $ withSubmissionData . calculateDeficit let bestCorrectors :: Set UserId bestCorrectors = acceptableCorrectors & maximumsBy (deficits !) & maximumsBy (tutors !?) $logDebugS "assignSubmissions" [st|#{tshow i} Tutors for #{tshow subId}: #{tshow tutors}|] $logDebugS "assignSubmissions" [st|#{tshow i} Current (#{tshow subId}) relevant deficits: #{tshow deficits}|] $logDebugS "assignSubmissions" [st|#{tshow i} Assigning #{tshow subId} to one of #{tshow bestCorrectors}|] ix subId . _1 <~ Just <$> liftIO (Rand.uniform bestCorrectors) return (fmap (view _1) newSubmissionData, oldDeficit) where maximumsBy :: (Ord a, Ord b) => (a -> b) -> Set a -> Set a maximumsBy f xs = flip Set.filter xs $ \x -> maybe True (((==) `on` f) x . maximumBy (comparing f)) $ fromNullable xs submissionFileSource :: SubmissionId -> ConduitT () (Entity File) (YesodDB UniWorX) () 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_ . E.exists . E.from $ \(sf' `E.InnerJoin` f') -> do E.on $ f' E.^. FileId E.==. sf' E.^. SubmissionFileFile E.where_ $ sf' E.^. SubmissionFileIsDeletion E.&&. sf' E.^. SubmissionFileSubmission E.==. sf E.^. SubmissionFileSubmission E.&&. f' E.^. FileTitle E.==. f E.^. FileTitle E.orderBy [E.desc $ sf E.^. SubmissionFileIsUpdate] -- E.desc returns corrector updated data first return (sf, f) submissionMultiArchive :: Bool -> Set SubmissionId -> Handler TypedContent submissionMultiArchive notAnonymized (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, sheet E.^. SheetAnonymousCorrection)) forM submissions $ \(s@(Entity submissionId _), courseSheetInfo) -> maybe (invalidArgs ["Invalid submission numbers"]) (return . (, s, $(E.unValueN 5) courseSheetInfo)) =<< getRating submissionId let (setSheet,setCourse,setSchool,setTerm) = execWriter . forM ratedSubmissions $ \(_rating,_submission,(shn,csh,ssh,tid,_anon)) -> tell (Set.singleton shn, Set.singleton csh, Set.singleton ssh, Set.singleton tid) archiveName <- ap getMessageRender $ pure MsgSubmissionArchiveName setContentDisposition' $ Just ((addExtension `on` unpack) archiveName extensionZip) (<* cleanup) . respondSource typeZip . transPipe (runDBRunner dbrunner) $ do let fileEntitySource' :: (Rating, Entity Submission, (SheetName,CourseShorthand,SchoolId,TermId,Bool)) -> ConduitT () File (YesodDB UniWorX) () fileEntitySource' (rating, Entity submissionID Submission{..},(shn,csh,ssh,tid,sheetAnonymous)) = do cID <- encrypt submissionID let dirFrag :: PathPiece p => p -> FilePath dirFrag = Text.unpack . toPathPiece withNames fp = do surnames <- lift . E.select . E.from $ \(user `E.InnerJoin` submissionUser) -> do E.on $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val submissionID return $ user E.^. UserSurname let asciiNames = sort $ map (filter isAlphaNum . foldMap unidecode . unpack . E.unValue) surnames return . intercalate "_" $ fp : asciiNames notAnonymized' <- and2M (return notAnonymized) (or2M (return $ not sheetAnonymous) (hasReadAccessTo $ CourseR tid ssh csh CCorrectionsR)) submissionDirectory <- bool return withNames notAnonymized' $ dirFrag (cID :: CryptoFileNameSubmission) let 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 :: Last Rating' , sinkSubmissionTouched :: Any , sinkSubmissionNotifyRating :: Any , sinkFilenames :: Set FilePath } deriving (Show, Eq, Generic, Typeable) instance Semigroup SubmissionSinkState where (<>) = mappenddefault instance Monoid SubmissionSinkState where mempty = memptydefault mappend = (<>) 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 ) => ConduitM File SubmissionContent m (Set FilePath) extractRatings = filterSubmission `fuseUpstream` Rating.extractRatings extractRatingsMsg :: ( MonadHandler m , HandlerSite m ~ UniWorX , MonadCatch m ) => ConduitT File SubmissionContent m () 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 -> ConduitT SubmissionContent Void (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{..} audit $ TransactionSubmissionEdit sId sheetId -- 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 -> ConduitT SubmissionContent SubmissionContent m () guardFileTitles SubmissionMode{..} | Just UploadAny{..} <- submissionModeUser , not isUpdate , Just (map unpack . Set.toList . toNullable -> exts) <- extensionRestriction = Conduit.mapM $ \x -> if | Left File{..} <- x , none ((flip isExtensionOf `on` CI.foldCase) 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 -> ConduitT SubmissionContent Void (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 subFileId <- insert $ SubmissionFile { submissionFileSubmission = submissionId , submissionFileFile = fileId , submissionFileIsUpdate = isUpdate , submissionFileIsDeletion = False } audit $ TransactionSubmissionFileEdit subFileId submissionId fileId when undoneDeletion $ do touchSubmission lift $ forM_ [ (sfId, submissionFileFile sf) | (_, Entity sfId sf) <- collidingFiles, submissionFileIsDeletion sf ] $ \(sfId, fId) -> audit $ TransactionSubmissionFileDelete sfId submissionId fId lift $ deleteWhere [ SubmissionFileId <-. [ sfId | (_, Entity sfId sf) <- collidingFiles, submissionFileIsDeletion sf ] ] Right (submissionId', r) -> do $logDebugS "sinkSubmission" $ tshow submissionId' unless (submissionId' == submissionId) $ do cID <- encrypt submissionId' throwM $ ForeignRating cID alreadySeen <- gets $ is (_Wrapped . _Just) . sinkSeenRating when alreadySeen $ throwM DuplicateRating submission <- lift $ getJust submissionId now <- liftIO getCurrentTime let rated = submissionRatingBy submission == Just userId -- FIXME: This behaviour is unintuitive and needs to be replaced with an "isDone"-Field in rating files r'@Rating'{..} = r { ratingTime = now <$ guard rated -- Ignore `ratingTime` from result @r@ of `parseRating` to ensure plausible timestamps (`parseRating` returns file modification time for consistency with `ratingFile`) } submission' = submission { submissionRatingPoints = ratingPoints , submissionRatingComment = ratingComment , submissionRatingTime = ratingTime , submissionRatingBy = userId <$ guard rated -- This is never an update due to the definition of rated; this is done so idempotency of uploads is maintained (FIXME: when "isDone"-Field is introduced, set this to `Just userId`) } tellSt $ mempty{ sinkSeenRating = Last $ Just r' } unless isUpdate $ throwM RatingWithoutUpdate -- 'ratingTime' is ignored for consistency with 'File's: -- -- 'fileModified' is simply stored and never inspected while -- 'submissionChanged' is always set to @now@. let anyChanges = any (\f -> f submission submission') $ [ (/=) `on` submissionRatingPoints , (/=) `on` submissionRatingComment , (/=) `on` submissionRatingDone , (/=) `on` submissionRatingBy ] when anyChanges $ do touchSubmission Sheet{..} <- lift . getJust $ submissionSheet submission' mapM_ throwM $ validateRating sheetType r' when (submissionRatingDone submission' && not (submissionRatingDone submission)) $ tellSt mempty { sinkSubmissionNotifyRating = Any True } lift $ replace submissionId submission' sheetId <- lift $ getSheetId lift $ audit $ TransactionSubmissionEdit submissionId sheetId 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} <- lift $ getJust submissionId when (is _Just submissionRatingTime) $ lift $ update submissionId [ SubmissionRatingTime =. Just now ] tellSt $ mempty{ sinkSubmissionTouched = Any True } getSheetId :: MonadIO m => ReaderT SqlBackend m SheetId getSheetId = case mExists of Left shid -> return shid Right _ -> submissionSheet <$> getJust submissionId -- there must have been a submission, otherwise mExists would have been Left shid 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 sfId' <- insert $ SubmissionFile { submissionFileSubmission = submissionId , submissionFileFile = f , submissionFileIsUpdate = True , submissionFileIsDeletion = True } audit $ TransactionSubmissionFileEdit sfId' submissionId f (E.Value f:_, True) -> do update sfId [ SubmissionFileFile =. f, SubmissionFileIsDeletion =. True ] deleteCascade fileId audit $ TransactionSubmissionFileDelete sfId submissionId f if | isUpdate , isn't (_Wrapped . _Just) sinkSeenRating -> do update submissionId [ SubmissionRatingTime =. Nothing, SubmissionRatingPoints =. Nothing, SubmissionRatingComment =. Nothing] sheetId <- getSheetId audit $ TransactionSubmissionEdit submissionId sheetId | isUpdate , getAny sinkSubmissionNotifyRating -> queueDBJob . JobQueueNotification $ NotificationSubmissionRated submissionId | not isUpdate , getAny sinkSubmissionTouched , is _Right mExists -> do uid <- requireAuthId queueDBJob . JobQueueNotification $ NotificationSubmissionEdited uid submissionId | otherwise -> return () sinkMultiSubmission :: UserId -> Bool {-^ Are these corrections -} -> ConduitT SubmissionContent Void (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 segments' = filter (not . Text.null) . Text.split (flip Set.notMember cryptoIdChars . CI.mk) $ Text.pack segment tryDecrypt ciphertext | Just cID <- fromPathPiece ciphertext = do sId <- decrypt (cID :: CryptoFileNameSubmission) Just sId <$ get404 sId | otherwise = return Nothing Alt msId <- lift . flip foldMapM segments' $ \seg -> Alt <$> lift (tryDecrypt seg) `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 lift . handle (throwM . SubmissionSinkException cID (Just fileTitle)) $ 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 cryptoIdChars :: Set (CI Char) cryptoIdChars = Set.fromList . map CI.mk $ "uwa" ++ "ABCDEFGHIJKLMNOPQRSTUVWXYZ234567" 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.subSelectMaybe . 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