1023 lines
50 KiB
Haskell
1023 lines
50 KiB
Haskell
module Handler.Utils.Submission
|
|
( AssignSubmissionException(..)
|
|
, assignSubmissions, writeSubmissionPlan, planSubmissions
|
|
, submissionBlacklist, filterSubmission, extractRatings, extractRatingsMsg
|
|
, submissionFileSource, submissionFileQuery
|
|
, SubmissionDownloadAnonymous(..)
|
|
, submissionMultiArchive
|
|
, SubmissionSinkException(..)
|
|
, msgSubmissionErrors -- wrap around sinkSubmission/sinkMultiSubmission, but outside of runDB!
|
|
, sinkSubmission, sinkMultiSubmission
|
|
, submissionMatchesSheet
|
|
, submissionDeleteRoute
|
|
, correctionInvisibleWidget
|
|
, AuthorshipStatementSubmissionState(..)
|
|
, getUserAuthorshipStatement, getSubmissionAuthorshipStatement
|
|
) where
|
|
|
|
import Import hiding (joinPath)
|
|
import Jobs.Queue
|
|
import Yesod.Core.Types (HandlerContents(..))
|
|
|
|
import qualified Control.Monad.State.Class as State
|
|
import Control.Monad.Trans.State (execStateT)
|
|
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 Database.Persist.Sql (SqlBackendCanRead)
|
|
import qualified Database.Esqueleto.Legacy as E
|
|
import qualified Database.Esqueleto.Utils.TH as E
|
|
|
|
import qualified Data.Conduit.List as Conduit
|
|
import Data.Conduit.ResumableSink
|
|
import qualified Data.Conduit.Combinators as C
|
|
|
|
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 . (`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
|
|
deficitWeight :: SubmissionId -> (Maybe UserId, Map UserId _, SheetId) -> Rational
|
|
deficitWeight subId (_, _, shId)
|
|
| Just restr' <- restriction = prop $ subId `Set.member` restr'
|
|
| otherwise = prop $ shId == sid
|
|
where prop = bool (byDeficit corrLoad) 1
|
|
|
|
sumDeficitWeight :: Map SubmissionId (Maybe UserId, Map UserId _, SheetId) -> Rational
|
|
sumDeficitWeight = getSum . ifoldMap (\subId x -> Sum $ deficitWeight subId x)
|
|
|
|
corrLoad = Map.findWithDefault mempty corrector sheetCorrectors
|
|
|
|
sheetSizes :: Map SheetId Rational
|
|
-- ^ Number of assigned submissions (to anyone) per sheet
|
|
sheetSizes = Map.map getSum . Map.fromListWith mappend $ do
|
|
(subId, x@(Just _, _, sheetId)) <- Map.toList submissionState
|
|
return (sheetId, Sum $ deficitWeight subId x)
|
|
|
|
deficitBySheet :: Map SheetId Rational
|
|
-- ^ Deficit of @corrector@ per sheet
|
|
deficitBySheet = flip Map.mapMaybeWithKey sheetSizes $ \sheetId sheetSize -> do
|
|
let assigned :: Rational
|
|
assigned = sumDeficitWeight $ 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 . sumDeficitWeight $ 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 * 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 <- State.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
|
|
|
|
unless (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 -> SubmissionFileType -> ConduitT () DBFile (YesodDB UniWorX) ()
|
|
submissionFileSource subId sft = E.selectSource (E.from $ submissionFileQuery subId sft)
|
|
.| C.map entityVal
|
|
.| sourceFiles'
|
|
|
|
submissionFileQuery :: SubmissionId -> SubmissionFileType
|
|
-> E.SqlExpr (Entity SubmissionFile)
|
|
-> E.SqlQuery (E.SqlExpr (Entity SubmissionFile))
|
|
submissionFileQuery submissionID sft sf = E.distinctOnOrderBy [E.asc $ sf E.^. SubmissionFileTitle] $ do
|
|
E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionID
|
|
case sft of
|
|
SubmissionOriginal ->
|
|
E.where_ . E.not_ $ sf E.^. SubmissionFileIsUpdate
|
|
E.||. sf E.^. SubmissionFileIsDeletion
|
|
SubmissionCorrected -> do
|
|
E.where_ . E.not_ . E.exists . E.from $ \sf' ->
|
|
E.where_ $ sf' E.^. SubmissionFileIsDeletion
|
|
E.&&. sf' E.^. SubmissionFileSubmission E.==. sf E.^. SubmissionFileSubmission
|
|
E.&&. sf' E.^. SubmissionFileTitle E.==. sf E.^. SubmissionFileTitle
|
|
E.orderBy [E.desc $ sf E.^. SubmissionFileIsUpdate] -- E.desc returns corrector updated data first
|
|
return sf
|
|
|
|
data SubmissionDownloadAnonymous = SubmissionDownloadAnonymous
|
|
| SubmissionDownloadSurnames
|
|
| SubmissionDownloadMatriculations
|
|
| SubmissionDownloadGroups
|
|
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
|
|
deriving anyclass (Universe, Finite)
|
|
|
|
nullaryPathPiece ''SubmissionDownloadAnonymous $ camelToPathPiece' 2
|
|
embedRenderMessage ''UniWorX ''SubmissionDownloadAnonymous id
|
|
makePrisms ''SubmissionDownloadAnonymous
|
|
|
|
submissionMultiArchive :: SubmissionDownloadAnonymous -> SubmissionFileType -> Set SubmissionId -> Handler TypedContent
|
|
submissionMultiArchive anonymous sft (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
|
|
let subTime = E.subSelectMaybe . E.from $ \submissionEdit -> do
|
|
E.where_ $ submissionEdit E.^. SubmissionEditSubmission E.==. submission E.^. SubmissionId
|
|
return . E.max_ $ submissionEdit E.^. SubmissionEditTime
|
|
return (submission, subTime, (sheet E.^. SheetName, course E.^. CourseShorthand, course E.^. CourseSchool, course E.^. CourseTerm, sheet E.^. SheetAnonymousCorrection))
|
|
|
|
forM submissions $ \(s@(Entity submissionId _), E.Value sTime, courseSheetInfo) ->
|
|
maybe (invalidArgs ["Invalid submission numbers"]) (return . (, s, sTime, $(E.unValueN 5) courseSheetInfo)) =<< getRating submissionId
|
|
let (setSheet,setCourse,setSchool,setTerm) =
|
|
execWriter . forM ratedSubmissions $ \(_rating,_submission,_subTime,(shn,csh,ssh,tid,_anon)) ->
|
|
tell (Set.singleton shn, Set.singleton csh, Set.singleton ssh, Set.singleton tid)
|
|
|
|
let
|
|
archiveName = case (Set.toList setTerm, Set.toList setSchool, Set.toList setCourse, Set.toList setSheet) of
|
|
([tid], [ssh], [csh], [shn])
|
|
-> MsgSubmissionTermSchoolCourseSheetArchiveName tid ssh csh shn
|
|
([tid], [ssh], [csh], _)
|
|
-> MsgSubmissionTermSchoolCourseArchiveName tid ssh csh
|
|
([tid], [ssh], _, _)
|
|
-> MsgSubmissionTermSchoolArchiveName tid ssh
|
|
([tid], _, _, _)
|
|
-> MsgSubmissionTermArchiveName tid
|
|
_other
|
|
-> MsgUtilSubmissionArchiveName
|
|
MsgRenderer mr <- getMsgRenderer
|
|
setContentDisposition' $ Just ((addExtension `on` unpack) (mr archiveName) extensionZip)
|
|
respondSource typeZip . (<* lift cleanup) . transPipe (runDBRunner dbrunner) $ do
|
|
let
|
|
fileEntitySource' :: (Rating, Entity Submission, Maybe UTCTime, (SheetName,CourseShorthand,SchoolId,TermId,Bool)) -> ConduitT () DBFile (YesodDB UniWorX) ()
|
|
fileEntitySource' (rating, Entity submissionID Submission{}, subTime, (shn,csh,ssh,tid,sheetAnonymous)) = do
|
|
cID <- encrypt submissionID
|
|
|
|
let
|
|
dirFrag :: PathPiece p => p -> FilePath
|
|
dirFrag = Text.unpack . toPathPiece
|
|
|
|
userFeature :: SubmissionDownloadAnonymous -> Maybe (E.SqlExpr (Entity User) -> E.SqlExpr (E.Value (Maybe Text)))
|
|
userFeature SubmissionDownloadSurnames = Just $ E.just . (E.^. UserSurname)
|
|
userFeature SubmissionDownloadMatriculations = Just $ E.castString . (E.^. UserMatrikelnummer)
|
|
userFeature _ = Nothing
|
|
|
|
withNames fp
|
|
| is _SubmissionDownloadGroups anonymous = do
|
|
groups <- lift . E.select . E.from $ \(submissionGroup `E.InnerJoin` submissionGroupUser `E.InnerJoin` submissionUser) -> do
|
|
E.on $ submissionUser E.^. SubmissionUserUser E.==. submissionGroupUser E.^. SubmissionGroupUserUser
|
|
E.on $ submissionGroup E.^. SubmissionGroupId E.==. submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup
|
|
E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val submissionID
|
|
E.where_ $ E.subSelectForeign submissionUser SubmissionUserSubmission (\submission -> E.subSelectForeign submission SubmissionSheet (E.^. SheetGrouping)) E.==. E.val RegisteredGroups
|
|
E.where_ . E.exists . E.from $ \(submission `E.InnerJoin` sheet) -> do
|
|
E.on $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId
|
|
E.where_ $ submission E.^. SubmissionId E.==. E.val submissionID
|
|
E.where_ $ sheet E.^. SheetCourse E.==. submissionGroup E.^. SubmissionGroupCourse
|
|
return $ submissionGroup E.^. SubmissionGroupName
|
|
let asciiGroups = Set.toList . Set.fromList $ map (filter isAlphaNum . foldMap unidecode . unpack . CI.original . E.unValue) groups
|
|
return . intercalate "_" $ asciiGroups `snoc` fp
|
|
| Just feature <- userFeature anonymous
|
|
= do
|
|
features <- 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 $ feature user
|
|
let asciiFeatures = sort $ mapMaybe (fmap (filter isAlphaNum . foldMap unidecode . unpack) . E.unValue) features
|
|
return . intercalate "_" $ asciiFeatures `snoc` fp
|
|
| otherwise = return fp
|
|
|
|
notAnonymized' <- and2M
|
|
(return $ isn't _SubmissionDownloadAnonymous anonymous)
|
|
(or2M (return $ not sheetAnonymous) (lift . 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
|
|
yieldM $ ratingFile cID rating
|
|
submissionFileSource submissionID sft
|
|
|
|
withinDirectory f@File{..} = f { fileTitle = directoryName </> fileTitle }
|
|
|
|
fileModified <- maybe (liftIO getCurrentTime) return subTime
|
|
yield $ File
|
|
{ fileModified
|
|
, fileTitle = directoryName
|
|
, fileContent = Nothing
|
|
}
|
|
|
|
fileEntitySource .| mapC withinDirectory
|
|
|
|
mapM_ fileEntitySource' ratedSubmissions .| produceZip def .| Conduit.map toFlushBuilder
|
|
|
|
|
|
|
|
|
|
|
|
data SubmissionSinkState = SubmissionSinkState
|
|
{ sinkSeenRating :: Last Rating'
|
|
, sinkSubmissionTouched :: 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 FileReference FileReference m (Set FilePath)
|
|
-- ^ Removes all `File`s matching `submissionBlacklist`, returning their `fileTitle`s
|
|
filterSubmission = do
|
|
$logDebugS "filterSubmission" $ tshow submissionBlacklist
|
|
execWriterLC . awaitForever $ \case
|
|
FileReference{fileReferenceTitle}
|
|
| any (`match'` fileReferenceTitle) submissionBlacklist -> tell $ Set.singleton fileReferenceTitle
|
|
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
|
|
) => ConduitM FileReference SubmissionContent m (Set FilePath)
|
|
extractRatings = filterSubmission `fuseUpstream` Rating.extractRatings
|
|
|
|
extractRatingsMsg :: ( MonadHandler m
|
|
, HandlerSite m ~ UniWorX
|
|
) => ConduitT FileReference 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
|
|
|
|
-- | Needs to *not* be called from within `runDB` so db transaction rollback can happen properly
|
|
--
|
|
-- Nontheless: we do assume elsewhere, that we can call `msgSubmissionErrors` from within `runDB` as long as we do `transactionUndo` iff it returns `Nothing`.
|
|
msgSubmissionErrors :: (MonadHandler m, MonadCatch m, HandlerSite m ~ UniWorX) => m a -> m (Maybe a)
|
|
msgSubmissionErrors = flip catches
|
|
[ 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
|
|
, E.Handler $ \e -> (Nothing <$) . addMessageWidget Error $ case e of
|
|
RatingFileException{..}
|
|
-> [whamlet|
|
|
$newline never
|
|
_{MsgRatingFileException ratingExceptionFile}
|
|
<br>
|
|
^{ratingExceptionWidget ratingException}
|
|
|]
|
|
RatingSubmissionException{..}
|
|
-> [whamlet|
|
|
$newline never
|
|
_{MsgRatingSubmissionException ratingExceptionSubmission}
|
|
<br>
|
|
^{ratingExceptionWidget ratingException}
|
|
|]
|
|
] . fmap Just
|
|
where
|
|
ratingExceptionWidget = \case
|
|
RatingFileIsDirectory -> i18n MsgRatingFileIsDirectory
|
|
RatingSubmissionIDIncorrect -> i18n MsgRatingSubmissionIDIncorrect
|
|
RatingValidityException exc -> i18n exc
|
|
RatingParseException pExc
|
|
-> [whamlet|
|
|
$newline never
|
|
_{MsgRatingParseException}
|
|
<br>
|
|
$case pExc
|
|
$of RatingYAMLStreamTerminatedUnexpectedly
|
|
_{MsgRatingYAMLStreamTerminatedUnexpectedly}
|
|
$of RatingYAMLDocumentEndIllDefined
|
|
_{MsgRatingYAMLDocumentEndIllDefined}
|
|
$of RatingYAMLExceptionBeforeComment errStr
|
|
_{MsgRatingYAMLExceptionBeforeComment}
|
|
<br>
|
|
<code .literal-error>
|
|
#{errStr}
|
|
$of RatingYAMLException errStr
|
|
_{MsgRatingYAMLException}
|
|
<br>
|
|
<code .literal-error>
|
|
#{errStr}
|
|
$of RatingYAMLCommentNotUnicode unicodeErr
|
|
_{MsgRatingYAMLCommentNotUnicode}
|
|
<br>
|
|
<code .literal-error>
|
|
#{tshow unicodeErr}
|
|
$of RatingYAMLNotUnicode unicodeErr
|
|
_{MsgRatingYAMLNotUnicode}
|
|
<br>
|
|
<code .literal-error>
|
|
#{unicodeErr}
|
|
|]
|
|
RatingParseLegacyException pExc
|
|
-> [whamlet|
|
|
$newline never
|
|
_{MsgRatingParseLegacyException}
|
|
<br>
|
|
$case pExc
|
|
$of RatingMissingSeparator
|
|
_{MsgRatingMissingSeparator}
|
|
$of RatingMultiple
|
|
_{MsgRatingMultiple}
|
|
$of RatingInvalid errStr
|
|
_{MsgRatingInvalid}
|
|
<br>
|
|
<code .literal-error>
|
|
#{errStr}
|
|
$of RatingNotUnicode unicodeErr
|
|
_{MsgRatingNotUnicode}
|
|
<br>
|
|
<code .literal-error>
|
|
#{tshow unicodeErr}
|
|
|]
|
|
|
|
|
|
sinkSubmission :: Maybe 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
|
|
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 = State.modify . mappend
|
|
|
|
guardFileTitles :: MonadThrow m => SubmissionMode -> ConduitT SubmissionContent SubmissionContent m ()
|
|
guardFileTitles SubmissionMode{..}
|
|
| Just UploadAny{..} <- submissionModeUser
|
|
, not isUpdate
|
|
, Just (map unpack . Set.toList . toNullable -> exts) <- uploadExtensionRestriction
|
|
= Conduit.mapM $ \x -> if
|
|
| Left FileReference{..} <- x
|
|
, none ((flip isExtensionOf `on` CI.foldCase) fileReferenceTitle) exts
|
|
, isn't _Nothing fileReferenceContent -- File record is not a directory, we don't care about those
|
|
-> throwM $ InvalidFileTitleExtension fileReferenceTitle
|
|
| 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@FileReference{..} -> do
|
|
$logDebugS "sinkSubmission" . tshow $ (submissionId, fileReferenceTitle)
|
|
|
|
alreadySeen <- State.gets (Set.member fileReferenceTitle . sinkFilenames)
|
|
when alreadySeen . throwM $ DuplicateFileTitle fileReferenceTitle
|
|
tellSt $ mempty{ sinkFilenames = Set.singleton fileReferenceTitle }
|
|
|
|
otherVersions <- lift . E.select . E.from $ \sf -> do
|
|
E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionId
|
|
-- E.where_ $ sf E.^. SubmissionFileIsUpdate E.==. E.val isUpdate
|
|
E.where_ $ sf E.^. SubmissionFileTitle E.==. E.val fileReferenceTitle -- 'Zip.hs' normalises filenames already, so this should work
|
|
return sf
|
|
|
|
let collidingFiles = [ t | t@(Entity _ sf) <- otherVersions
|
|
, submissionFileIsUpdate sf == isUpdate
|
|
]
|
|
underlyingFiles = [ t | t@(Entity _ sf) <- otherVersions
|
|
, not (submissionFileIsUpdate sf)
|
|
]
|
|
anyChanges
|
|
| not (null collidingFiles) = any (/~ file) [ view (_FileReference . _1) sf | Entity _ sf <- collidingFiles ]
|
|
| otherwise = True
|
|
matchesUnderlying
|
|
| not (null underlyingFiles) = all (~~ file) [ view (_FileReference . _1) sf | Entity _ sf <- underlyingFiles ]
|
|
| otherwise = False
|
|
undoneDeletion = any submissionFileIsDeletion [ sf | Entity _ sf <- collidingFiles ]
|
|
|
|
when anyChanges $ do
|
|
touchSubmission
|
|
forM_ collidingFiles $ \sfEnt@(Entity sfId' _) -> lift $ do
|
|
delete sfId'
|
|
audit $ TransactionSubmissionFileDelete sfEnt
|
|
lift $ if
|
|
| matchesUnderlying
|
|
, isUpdate
|
|
-> return ()
|
|
| otherwise -> do
|
|
subFile <- insertEntity $
|
|
_FileReference # ( file
|
|
, SubmissionFileResidual
|
|
{ submissionFileResidualSubmission = submissionId
|
|
, submissionFileResidualIsUpdate = isUpdate
|
|
, submissionFileResidualIsDeletion = False
|
|
}
|
|
)
|
|
audit $ TransactionSubmissionFileEdit subFile
|
|
when undoneDeletion $ do
|
|
touchSubmission
|
|
forM_ (filter (submissionFileIsDeletion . entityVal) collidingFiles) $ \sfEnt@(Entity sfId' _) -> lift $ do
|
|
delete sfId'
|
|
audit $ TransactionSubmissionFileDelete sfEnt
|
|
|
|
Right (submissionId', r) -> do
|
|
$logDebugS "sinkSubmission" $ tshow submissionId'
|
|
cID <- encrypt submissionId'
|
|
|
|
unless (submissionId' == submissionId) $
|
|
throwM $ ForeignRating cID
|
|
|
|
alreadySeen <- State.gets $ is (_Wrapped . _Just) . sinkSeenRating
|
|
when alreadySeen $ throwM DuplicateRating
|
|
|
|
submission <- lift $ getJust submissionId
|
|
|
|
now <- liftIO getCurrentTime
|
|
let rated = ratingDone r
|
|
let
|
|
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
|
|
}
|
|
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 . RatingSubmissionException cID . RatingValidityException) $ validateRating sheetType r'
|
|
|
|
lift $ replace submissionId submission'
|
|
sheetId <- lift getSheetId
|
|
lift $ audit $ TransactionSubmissionEdit submissionId sheetId
|
|
where
|
|
a /~ b = not $ a ~~ b
|
|
|
|
(~~) :: FileReference -> FileReference -> Bool
|
|
(~~) a b
|
|
| isUpdate = fileReferenceTitle a == fileReferenceTitle b
|
|
&& fileReferenceContent a == fileReferenceContent 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 <- State.gets $ getAny . sinkSubmissionTouched
|
|
unless alreadyTouched $ do
|
|
now <- liftIO getCurrentTime
|
|
if
|
|
| isUpdate -> do
|
|
Submission{submissionRatingTime} <- lift $ getJust submissionId
|
|
when (is _Just submissionRatingTime) $
|
|
lift $ update submissionId [ SubmissionRatingTime =. Just now ]
|
|
| otherwise -> lift . insert_ $ SubmissionEdit userId now submissionId
|
|
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 sState = do
|
|
SubmissionSinkState{..} <- flip execStateT sState $
|
|
when (is _Left mExists)
|
|
touchSubmission
|
|
|
|
missingFiles <- E.select . E.from $ \sf -> E.distinctOnOrderBy [E.asc $ sf E.^. SubmissionFileTitle] $ do
|
|
E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionId
|
|
unless isUpdate $
|
|
E.where_ . E.not_ $ sf E.^. SubmissionFileIsUpdate
|
|
E.where_ $ sf E.^. SubmissionFileTitle `E.notIn` E.valList (Set.toList sinkFilenames)
|
|
E.orderBy [E.desc $ sf E.^. SubmissionFileIsUpdate]
|
|
|
|
return sf
|
|
|
|
if
|
|
| isUpdate -> forM_ missingFiles $ \sfEnt@(Entity sfId SubmissionFile{..}) -> do
|
|
shadowing <- existsBy $ UniqueSubmissionFile submissionFileSubmission submissionFileTitle False
|
|
|
|
if
|
|
| not shadowing -> do
|
|
delete sfId
|
|
audit $ TransactionSubmissionFileDelete sfEnt
|
|
| submissionFileIsUpdate -> do
|
|
sfRec <- updateGet sfId [ SubmissionFileContent =. Nothing, SubmissionFileIsDeletion =. True ]
|
|
audit . TransactionSubmissionFileEdit $ Entity sfId sfRec
|
|
| otherwise -> do
|
|
now <- liftIO getCurrentTime
|
|
sfEnt' <- insertEntity $ SubmissionFile
|
|
{ submissionFileSubmission = submissionId
|
|
, submissionFileTitle
|
|
, submissionFileModified = now
|
|
, submissionFileContent = Nothing
|
|
, submissionFileIsUpdate = True
|
|
, submissionFileIsDeletion = True
|
|
}
|
|
audit $ TransactionSubmissionFileEdit sfEnt'
|
|
| otherwise -> do
|
|
shadowed <- selectList
|
|
[ SubmissionFileSubmission ==. submissionId
|
|
, SubmissionFileIsUpdate ==. False
|
|
, SubmissionFileId <-. map entityKey missingFiles
|
|
] []
|
|
forM_ shadowed $ \sfEnt'@(Entity sfId' _) -> do
|
|
delete sfId'
|
|
audit $ TransactionSubmissionFileDelete sfEnt'
|
|
|
|
if
|
|
| isUpdate
|
|
, isn't (_Wrapped . _Just) sinkSeenRating
|
|
-> do
|
|
update submissionId [ SubmissionRatingTime =. Nothing, SubmissionRatingPoints =. Nothing, SubmissionRatingComment =. Nothing]
|
|
sheetId <- getSheetId
|
|
audit $ TransactionSubmissionEdit submissionId sheetId
|
|
| 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 <- State.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
|
|
hoist lift $ guardAuthResult =<< evalAccessDB (CSubmissionR courseTerm courseSchool courseShorthand sheetName cID CorrectionR) True
|
|
return . newResumableSink $ sinkSubmission (Just userId) (Right sId) isUpdate
|
|
sink' <- lift $ yield val ++$$ sink
|
|
case sink' of
|
|
Left _ -> error "sinkSubmission returned prematurely"
|
|
Right nSink -> State.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@FileReference{..}) -> 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
|
|
Dual (Alt msId) <- lift . flip foldMapM segments' $ \seg -> Dual . Alt <$> lift (tryDecrypt seg) `catches` [ E.Handler handleCryptoID, E.Handler (handleHCError $ Right fileReferenceTitle) ]
|
|
return (msId, fp)
|
|
(msId, joinPath -> fileTitle') <- foldM acc (Nothing, []) $ splitDirectories fileReferenceTitle
|
|
case msId of
|
|
Nothing -> do
|
|
$logDebugS "sinkMultiSubmission" $ "Dropping " <> tshow (splitDirectories fileReferenceTitle, msId, fileTitle')
|
|
Just sId -> do
|
|
$logDebugS "sinkMultiSubmission" $ "Feeding " <> tshow (splitDirectories fileReferenceTitle, msId, fileTitle')
|
|
cID <- encrypt sId
|
|
lift . handle (throwM . SubmissionSinkException cID (Just fileReferenceTitle)) $
|
|
feed sId $ Left f{ fileReferenceTitle = fileTitle' }
|
|
unless (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 [MsgUtilSubmissionWrongSheet]
|
|
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
|
|
| not $ null subUsers
|
|
, maybe True (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
|
|
}
|
|
|
|
|
|
data CorrectionInvisibleReason
|
|
= CorrectionInvisibleExamUnfinished
|
|
| CorrectionInvisibleRatingNotDone
|
|
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
|
|
deriving anyclass (Universe, Finite)
|
|
embedRenderMessage ''UniWorX ''CorrectionInvisibleReason id
|
|
|
|
correctionInvisibleWidget :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission
|
|
-> Entity Submission
|
|
-> DB (Maybe Widget)
|
|
correctionInvisibleWidget tid ssh csh shn cID (Entity subId sub) = runMaybeT $ do
|
|
submittors <- lift . fmap (Set.fromList . fmap E.unValue) . E.select . E.from $ \submissionUser -> do
|
|
E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val subId
|
|
return $ submissionUser E.^. SubmissionUserUser
|
|
|
|
corrVisible <- lift . allM submittors $ \bId -> is _Authorized <$> evalAccessFor (Just bId) (CSubmissionR tid ssh csh shn cID CorrectionR) False
|
|
guard $ not corrVisible
|
|
|
|
reasons <- lift . mapReaderT execWriterT $ do
|
|
unless (submissionRatingDone sub) $
|
|
tellPoint @(Set _) CorrectionInvisibleRatingNotDone
|
|
maybeT_ $ do
|
|
Sheet{..} <- MaybeT . get $ submissionSheet sub
|
|
epId <- hoistMaybe $ sheetType ^? _examPart . from _SqlKey
|
|
ExamPart{examPartExam} <- MaybeT $ get epId
|
|
Exam{..} <- MaybeT $ get examPartExam
|
|
now <- liftIO getCurrentTime
|
|
unless (NTop (Just now) >= NTop examFinished) $
|
|
tellPoint CorrectionInvisibleExamUnfinished
|
|
|
|
return $ notification NotificationBroad =<< messageIconWidget Warning IconInvisible $(widgetFile "submission-correction-invisible")
|
|
|
|
|
|
getUserAuthorshipStatement :: ( MonadResource m
|
|
, IsSqlBackend backend, SqlBackendCanRead backend
|
|
)
|
|
=> Maybe (Entity AuthorshipStatementDefinition) -- ^ Currently expected authorship statement; see `getSheetAuthorshipStatement`
|
|
-> SubmissionId
|
|
-> UserId
|
|
-> ReaderT backend m AuthorshipStatementSubmissionState
|
|
getUserAuthorshipStatement mASDefinition subId uid = runConduit $
|
|
getStmts
|
|
.| fmap toRes (execWriterC . C.mapM_ $ tell . toPoint)
|
|
where
|
|
getStmts = E.selectSource . E.from $ \authorshipStatementSubmission -> do
|
|
E.where_ $ authorshipStatementSubmission E.^. AuthorshipStatementSubmissionSubmission E.==. E.val subId
|
|
E.&&. authorshipStatementSubmission E.^. AuthorshipStatementSubmissionUser E.==. E.val uid
|
|
return authorshipStatementSubmission
|
|
toPoint :: Entity AuthorshipStatementSubmission -> Maybe Any
|
|
toPoint (Entity _ AuthorshipStatementSubmission{..}) = Just . Any $ fmap entityKey mASDefinition == Just authorshipStatementSubmissionStatement
|
|
toRes :: Maybe Any -> AuthorshipStatementSubmissionState
|
|
toRes = \case
|
|
Just (Any True) -> ASExists
|
|
Just (Any False) -> ASOldStatement
|
|
Nothing -> ASMissing
|
|
|
|
getSubmissionAuthorshipStatement :: ( MonadResource m
|
|
, IsSqlBackend backend, SqlBackendCanRead backend
|
|
)
|
|
=> Maybe (Entity AuthorshipStatementDefinition) -- ^ Currently expected authorship statement; see `getSheetAuthorshipStatement`
|
|
-> SubmissionId
|
|
-> ReaderT backend m AuthorshipStatementSubmissionState
|
|
getSubmissionAuthorshipStatement mASDefinition subId = fmap (fromMaybe ASMissing) . runConduit $
|
|
sourceSubmissionUsers
|
|
.| C.map E.unValue
|
|
.| C.mapM getUserAuthorshipStatement'
|
|
.| C.maximum
|
|
where
|
|
getUserAuthorshipStatement' = getUserAuthorshipStatement mASDefinition subId
|
|
sourceSubmissionUsers = E.selectSource . E.from $ \submissionUser -> do
|
|
E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val subId
|
|
return $ submissionUser E.^. SubmissionUserUser
|