806 lines
40 KiB
Haskell
806 lines
40 KiB
Haskell
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
|
|
<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'}|]
|
|
, drFormMessage = \infos -> do
|
|
let
|
|
coSubWarning (E.Value subId, _, _, _, _, _, _) = do
|
|
uid <- maybeAuthId
|
|
subUsers <- selectList [SubmissionUserSubmission ==. subId] []
|
|
if
|
|
| length subUsers >= 1
|
|
, maybe False (flip any subUsers . (. submissionUserUser . entityVal) . (==)) uid
|
|
-> Just <$> messageI Warning (MsgSubmissionDeleteCosubmittorsWarning $ length infos)
|
|
| otherwise
|
|
-> return Nothing
|
|
|
|
coSubWarning' <- foldMapM (fmap First . coSubWarning) infos
|
|
|
|
return $ getFirst coSubWarning'
|
|
, drCaption = SomeMessage $ MsgSubmissionsDeleteQuestion 1
|
|
, drSuccessMessage = SomeMessage $ MsgSubmissionsDeleted 1
|
|
, drAbort = error "drAbort undefined"
|
|
, drSuccess = error "drSuccess undefined"
|
|
, drDelete = \subId del -> do
|
|
Submission{..} <- getJust subId
|
|
subUsers <- setOf (folded . _entityVal . _submissionUserUser) <$> selectList [SubmissionUserSubmission ==. subId] []
|
|
audit $ TransactionSubmissionDelete subId submissionSheet
|
|
|
|
uid <- requireAuthId
|
|
forM_ (Set.delete uid subUsers) $ \subUid ->
|
|
queueDBJob . JobQueueNotification $ NotificationSubmissionUserDeleted subUid submissionSheet subId
|
|
|
|
del
|
|
}
|