641 lines
30 KiB
Haskell
641 lines
30 KiB
Haskell
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)
|
|
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.Submission.TH
|
|
import Handler.Utils.Delete
|
|
|
|
import qualified Database.Esqueleto 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) -> 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.==. tutorialUser E.^. TutorialUserTutorial)
|
|
E.on (submissionUser E.^. SubmissionUserUser E.==. tutorialUser E.^. TutorialUserUser)
|
|
E.where_ (tutorial E.^. TutorialTutor `E.in_` E.valList (map (sheetCorrectorUser . entityVal) corrsTutorial))
|
|
return $ tutorial E.^. TutorialTutor
|
|
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)
|
|
|
|
let subTutor' :: Map SubmissionId (Set UserId)
|
|
subTutor' = Map.fromListWith Set.union $ currentSubs
|
|
& mapped._2 %~ maybe Set.empty Set.singleton
|
|
& mapped._2 %~ Set.mapMonotonic entityKey
|
|
& 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) -> do
|
|
E.on $ tutorial E.^. TutorialId E.==. tutorialUser E.^. TutorialUserTutorial
|
|
E.on $ submissionUser E.^. SubmissionUserUser E.==. tutorialUser E.^. TutorialUserUser
|
|
E.where_ $ tutorial E.^. TutorialTutor 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 <- 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
|
|
fileEntitySource' (rating, Entity submissionID Submission{..}) = do
|
|
cID <- encrypt submissionID
|
|
|
|
let
|
|
directoryName = Text.unpack $ toPathPiece (cID :: CryptoFileNameSubmission)
|
|
|
|
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
|
|
|
|
submissionBlacklist :: [Pattern]
|
|
submissionBlacklist = $(patternFile compDefault "config/submission-blacklist")
|
|
|
|
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
|
|
mr <- (toHtml . ) <$> getMessageRender
|
|
addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionFilesIgnored.hamlet") mr)
|
|
|
|
-- 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
|
|
|
|
sId <$ sinkSubmission' sId
|
|
where
|
|
tellSt = modify . mappend
|
|
|
|
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} <- lift $ getJust submissionId
|
|
when (isNothing submissionRatingTime) $ tellSt mempty { sinkSubmissionNotifyRating = Any True }
|
|
lift $ update submissionId [ SubmissionRatingBy =. Just userId, SubmissionRatingTime =. Just now ]
|
|
-- TODO: Should submissionRatingAssigned change here if userId changes?
|
|
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
|
|
, SubmissionRatingBy =. 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
|
|
<ul .list--comma-separated .list--inline .list--iconless>
|
|
$forall (dName, sName) <- subNames
|
|
<li>^{nameWidget dName sName}
|
|
(_{ShortTermIdentifier (unTermKey tid')}, #{sName}, #{cName}, #{shn'})
|
|
|]
|
|
, drRecordConfirmString = \(E.Value subId', E.Value shn', E.Value csh', _, E.Value ssh', _, E.Value tid') -> do
|
|
subUsers <- selectList [SubmissionUserSubmission ==. subId'] []
|
|
subNames <- fmap sort . forM subUsers $ \(Entity _ SubmissionUser{submissionUserUser}) -> userSurname <$> getJust submissionUserUser
|
|
let subNames' = Text.intercalate ", " subNames
|
|
return [st|#{termToText (unTermKey tid')}/#{ssh'}/#{csh'}/#{shn'}/#{subNames'}|]
|
|
, drCaption = SomeMessage $ MsgSubmissionsDeleteQuestion 1
|
|
, drSuccessMessage = SomeMessage $ MsgSubmissionsDeleted 1
|
|
, drAbort = error "drAbort undefined"
|
|
, drSuccess = error "drSuccess undefined"
|
|
}
|