269 lines
11 KiB
Haskell
269 lines
11 KiB
Haskell
{-# LANGUAGE NoImplicitPrelude #-}
|
|
{-# LANGUAGE RecordWildCards #-}
|
|
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE ViewPatterns #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE TupleSections #-}
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
{-# LANGUAGE LambdaCase #-}
|
|
{-# LANGUAGE TemplateHaskell #-}
|
|
{-# LANGUAGE DeriveGeneric, DeriveDataTypeable #-}
|
|
|
|
|
|
module Handler.Utils.Submission
|
|
( SubmissionSinkException(..)
|
|
, sinkSubmission
|
|
) where
|
|
|
|
import Import -- hiding ()
|
|
|
|
import Control.Lens
|
|
import Control.Lens.Extras (is)
|
|
import Utils.Lens
|
|
|
|
import Control.Monad.State hiding (forM_)
|
|
|
|
import Data.Maybe
|
|
|
|
import Data.Set (Set)
|
|
import qualified Data.Set as Set
|
|
import Data.Map (Map)
|
|
import qualified Data.Map as Map
|
|
|
|
|
|
import Data.Monoid (Monoid, Any(..))
|
|
import Generics.Deriving.Monoid (memptydefault, mappenddefault)
|
|
|
|
import Handler.Utils.Rating
|
|
|
|
import qualified Database.Esqueleto as E
|
|
|
|
import qualified Data.Conduit.List as Conduit
|
|
|
|
|
|
assignSubmissions :: SheetId -> YesodDB UniWorX ()
|
|
assignSubmissions sid = do
|
|
correctors <- selectList [SheetCorrectorSheet ==. sid] []
|
|
let (corrsGroup, normalize -> corrsProp) = partition (is _ByTutorial . sheetCorrectorLoad . entityVal) correctors
|
|
subs <- E.select . E.from $ \(submission `E.LeftOuterJoin` user) -> 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) corrsGroup))
|
|
return $ tutorial E.^. TutorialTutor
|
|
E.on $ user E.?. UserId `E.in_` E.justList tutors
|
|
E.where_ $ submission E.^. SubmissionSheet E.==. E.val sid
|
|
E.orderBy [E.rand] -- randomize for fair tutor distribution
|
|
return (submission E.^. SubmissionId, user E.?. UserId) -- , listToMaybe tutors)
|
|
let subTutor :: Map SubmissionId (Maybe UserId)
|
|
subTutor = Map.fromListWith (<|>) $ map (bimap E.unValue E.unValue) subs
|
|
-- TODO: Continue here --
|
|
return ()
|
|
where
|
|
_Load :: Traversal' (Entity SheetCorrector) Rational
|
|
_Load = _entityVal . _sheetCorrectorLoad . _ByProportion
|
|
|
|
normalize :: [Entity SheetCorrector] -> [Entity SheetCorrector]
|
|
normalize corrsProp = corrsProp & each . _Load //~ sumOf (each . _Load) corrsProp
|
|
|
|
|
|
|
|
data SubmissionSinkState = SubmissionSinkState
|
|
{ sinkSeenRating :: Any
|
|
, sinkSubmissionTouched :: Any
|
|
, sinkFilenames :: Set FilePath
|
|
} deriving (Show, Eq, Generic, Typeable)
|
|
|
|
instance Monoid SubmissionSinkState where
|
|
mempty = memptydefault
|
|
mappend = mappenddefault
|
|
|
|
data SubmissionSinkException = DuplicateFileTitle FilePath
|
|
| DuplicateRating
|
|
| RatingWithoutUpdate
|
|
| ForeignRating
|
|
deriving (Typeable, Show)
|
|
|
|
instance Exception SubmissionSinkException
|
|
|
|
sinkSubmission :: SheetId
|
|
-> UserId
|
|
-> Maybe (SubmissionId, Bool {-^ Is this a correction -})
|
|
-> Sink SubmissionContent (YesodDB 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 sheetId userId mExists = do
|
|
now <- liftIO getCurrentTime
|
|
let
|
|
submissionSheet = sheetId
|
|
submissionRatingPoints = Nothing
|
|
submissionRatingComment = Nothing
|
|
submissionRatingBy = Nothing
|
|
submissionRatingTime = Nothing
|
|
|
|
(sId, isUpdate) <- lift $ maybe ((, False) <$> (insert Submission{..} >>= (\sid -> sid <$ insert (SubmissionEdit userId now sid)))) return mExists
|
|
|
|
|
|
sId <$ sinkSubmission' sId isUpdate
|
|
where
|
|
tell = modify . mappend
|
|
|
|
sinkSubmission' :: SubmissionId
|
|
-> Bool -- ^ Is this a correction
|
|
-> Sink SubmissionContent (YesodDB UniWorX) ()
|
|
sinkSubmission' submissionId isUpdate = 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
|
|
tell $ 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', Rating'{..}) -> do
|
|
$logDebugS "sinkSubmission" $ tshow submissionId'
|
|
|
|
unless (submissionId' == submissionId) $ throwM ForeignRating
|
|
|
|
alreadySeen <- gets $ getAny . sinkSeenRating
|
|
when alreadySeen $ throwM DuplicateRating
|
|
tell $ 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
|
|
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 (YesodDB UniWorX) ()
|
|
touchSubmission = do
|
|
alreadyTouched <- gets $ getAny . sinkSubmissionTouched
|
|
when (not alreadyTouched) $ do
|
|
now <- liftIO getCurrentTime
|
|
lift $ case isUpdate of
|
|
False -> insert_ $ SubmissionEdit userId now submissionId
|
|
True -> update submissionId [ SubmissionRatingBy =. Just userId, SubmissionRatingTime =. Just now ]
|
|
tell $ mempty{ sinkSubmissionTouched = Any True }
|
|
|
|
finalize :: SubmissionSinkState -> YesodDB 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
|
|
|
|
when (isUpdate && not (getAny sinkSeenRating)) $
|
|
update submissionId
|
|
[ SubmissionRatingTime =. Nothing
|
|
, SubmissionRatingPoints =. Nothing
|
|
, SubmissionRatingBy =. Nothing
|
|
, SubmissionRatingComment =. Nothing
|
|
]
|