497 lines
22 KiB
Haskell
497 lines
22 KiB
Haskell
{-# LANGUAGE NoImplicitPrelude #-}
|
|
{-# LANGUAGE RecordWildCards #-}
|
|
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE ViewPatterns #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE TupleSections #-}
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
{-# LANGUAGE LambdaCase #-}
|
|
{-# LANGUAGE TemplateHaskell #-}
|
|
{-# LANGUAGE DeriveGeneric, DeriveDataTypeable #-}
|
|
{-# LANGUAGE TypeOperators #-}
|
|
{-# LANGUAGE PartialTypeSignatures #-}
|
|
|
|
|
|
module Handler.Utils.Submission
|
|
( AssignSubmissionException(..)
|
|
, assignSubmissions
|
|
, submissionBlacklist, filterSubmission, extractRatings, extractRatingsMsg
|
|
, submissionFileSource, submissionFileQuery
|
|
, submissionMultiArchive
|
|
, SubmissionSinkException(..)
|
|
, sinkSubmission, sinkMultiSubmission
|
|
, submissionMatchesSheet
|
|
) where
|
|
|
|
import Import hiding ((.=), joinPath)
|
|
|
|
import Control.Lens
|
|
import Control.Lens.Extras (is)
|
|
import Utils.Lens
|
|
|
|
import Control.Monad.State hiding (forM_, mapM_,foldM)
|
|
import Control.Monad.Writer (MonadWriter(..))
|
|
import qualified Control.Monad.Random as Rand
|
|
|
|
import Data.Maybe
|
|
|
|
import qualified Data.List as List
|
|
import Data.Set (Set)
|
|
import qualified Data.Set as Set
|
|
import Data.Map (Map, (!?))
|
|
import qualified Data.Map as Map
|
|
|
|
import Data.CaseInsensitive (CI)
|
|
import qualified Data.CaseInsensitive as CI
|
|
|
|
import Data.Monoid (Monoid, Any(..))
|
|
import Generics.Deriving.Monoid (memptydefault, mappenddefault)
|
|
|
|
import Handler.Utils.Rating hiding (extractRatings)
|
|
import qualified Handler.Utils.Rating as Rating (extractRatings)
|
|
import Handler.Utils.Zip
|
|
import Handler.Utils.Sheet
|
|
import Handler.Utils.Submission.TH
|
|
|
|
import qualified Database.Esqueleto as E
|
|
|
|
import Data.Conduit
|
|
import qualified Data.Conduit.List as Conduit
|
|
import Data.Conduit.ResumableSink
|
|
|
|
import System.FilePath
|
|
import System.FilePath.Glob
|
|
|
|
import Text.Hamlet (ihamletFile)
|
|
|
|
|
|
data AssignSubmissionException = NoCorrectorsByProportion
|
|
deriving (Typeable, Show)
|
|
|
|
instance Exception AssignSubmissionException
|
|
|
|
-- | Assigns all submissions according to sheet corrector loads
|
|
assignSubmissions :: SheetId -- ^ Sheet do distribute to correction
|
|
-> Maybe (Set SubmissionId) -- ^ Optionally restrict submission to consider
|
|
-> YesodDB UniWorX ( Set SubmissionId -- ^ assigned submissions
|
|
, Set SubmissionId -- ^ unassigend submissions (no tutors by load)
|
|
)
|
|
assignSubmissions sid restriction = do
|
|
correctors <- selectList [SheetCorrectorSheet ==. sid] []
|
|
let corrsGroup = filter hasTutorialLoad correctors -- needed as List within Esqueleto
|
|
let corrsProp = filter hasPositiveLoad correctors
|
|
let countsToLoad' :: UserId -> Bool
|
|
countsToLoad' uid = -- refactor by simply using Map.(!)
|
|
fromMaybe (error "Called `countsToLoad'` on entity not element of `corrsGroup`") $
|
|
Map.lookup uid loadMap
|
|
loadMap :: Map UserId Bool
|
|
loadMap = Map.fromList [(sheetCorrectorUser,b) | Entity _ SheetCorrector{ sheetCorrectorLoad = (Load {byTutorial = Just b}), .. } <- corrsGroup]
|
|
|
|
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.&&. maybe (E.val True) (submission E.^. SubmissionId `E.in_`) (E.valList . Set.toList <$> restriction)
|
|
E.orderBy [E.rand] -- randomize for fair tutor distribution
|
|
return (submission E.^. SubmissionId, user) -- , listToMaybe tutors)
|
|
|
|
queue <- liftIO . Rand.evalRandIO . sequence . repeat $ Rand.weightedMay [ (sheetCorrectorUser, byProportion sheetCorrectorLoad) | Entity _ SheetCorrector{..} <- corrsProp]
|
|
|
|
let subTutor' :: Map SubmissionId (Maybe UserId)
|
|
subTutor' = Map.fromListWith (<|>) $ map (over (_2.traverse) entityKey . over _1 E.unValue) subs
|
|
|
|
subTutor <- fmap fst . flip execStateT (Map.empty, queue) . forM_ (Map.toList subTutor') $ \case
|
|
(smid, Just tutid) -> do
|
|
_1 %= Map.insert smid tutid
|
|
when (any ((== tutid) . sheetCorrectorUser . entityVal) corrsProp && countsToLoad' tutid) $
|
|
_2 %= List.delete (Just tutid)
|
|
(smid, Nothing) -> do
|
|
(q:qs) <- use _2
|
|
_2 .= qs
|
|
case q of
|
|
Just q -> _1 %= Map.insert smid q
|
|
Nothing -> return () -- NOTE: throwM NoCorrectorsByProportion
|
|
|
|
forM_ (Map.toList subTutor) $ \(smid, tutid) -> update smid [SubmissionRatingBy =. Just tutid]
|
|
|
|
let assignedSubmissions = Map.keysSet subTutor
|
|
unassigendSubmissions = Map.keysSet subTutor' \\ assignedSubmissions
|
|
return (assignedSubmissions, unassigendSubmissions)
|
|
where
|
|
hasPositiveLoad = (> 0) . byProportion . sheetCorrectorLoad . entityVal
|
|
hasTutorialLoad = isJust . byTutorial . sheetCorrectorLoad . entityVal
|
|
|
|
|
|
submissionFileSource :: SubmissionId -> Source (YesodDB UniWorX) (Entity File)
|
|
submissionFileSource = E.selectSource . fmap snd . E.from . submissionFileQuery
|
|
|
|
submissionFileQuery :: SubmissionId -> E.SqlExpr (Entity SubmissionFile) `E.InnerJoin` E.SqlExpr (Entity File)
|
|
-> E.SqlQuery (E.SqlExpr (Entity SubmissionFile), E.SqlExpr (Entity File))
|
|
submissionFileQuery submissionID (sf `E.InnerJoin` f) = E.distinctOnOrderBy [E.asc $ f E.^. FileTitle] $ do
|
|
E.on (f E.^. FileId E.==. sf E.^. SubmissionFileFile)
|
|
E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionID
|
|
E.where_ . E.not_ $ sf E.^. SubmissionFileIsDeletion -- TODO@gk: won't work as intended! Fix with refactor
|
|
E.orderBy [E.desc $ sf E.^. SubmissionFileIsUpdate] -- E.desc returns corrector updated data first
|
|
return (sf, f)
|
|
|
|
submissionMultiArchive :: Set SubmissionId -> Handler TypedContent
|
|
submissionMultiArchive (Set.toList -> ids) = do
|
|
(dbrunner, cleanup) <- getDBRunner
|
|
|
|
ratedSubmissions <- runDBRunner dbrunner $ do
|
|
submissions <- selectList [ SubmissionId <-. ids ] []
|
|
forM submissions $ \s@(Entity submissionId _) -> maybe (invalidArgs ["Invalid submission numbers"]) (return . (, s)) =<< getRating submissionId
|
|
|
|
(<* cleanup) . respondSource "application/zip" . transPipe (runDBRunner dbrunner) $ do
|
|
let
|
|
fileEntitySource' :: (Rating, Entity Submission) -> Source (YesodDB UniWorX) File
|
|
fileEntitySource' (rating, Entity submissionID Submission{..}) = do
|
|
cID <- encrypt submissionID
|
|
|
|
let
|
|
directoryName = CI.foldedCase $ ciphertext (cID :: CryptoFileNameSubmission)
|
|
|
|
fileEntitySource = do
|
|
submissionFileSource submissionID =$= Conduit.map entityVal
|
|
yieldM (ratingFile cID rating)
|
|
|
|
withinDirectory f@File{..} = f { fileTitle = directoryName </> fileTitle }
|
|
|
|
lastEditMb <- lift $ selectList [SubmissionEditSubmission ==. submissionID] [Desc SubmissionEditTime, LimitTo 1]
|
|
lastEditTime <- case lastEditMb of
|
|
[(submissionEditTime.entityVal -> time)] -> return time
|
|
_other -> liftIO getCurrentTime
|
|
yield $ File
|
|
{ fileModified = lastEditTime
|
|
, fileTitle = directoryName
|
|
, fileContent = Nothing
|
|
}
|
|
|
|
fileEntitySource =$= mapC withinDirectory
|
|
|
|
mapM_ fileEntitySource' ratedSubmissions =$= produceZip def =$= Conduit.map toFlushBuilder
|
|
|
|
|
|
|
|
|
|
|
|
data SubmissionSinkState = SubmissionSinkState
|
|
{ sinkSeenRating :: Any
|
|
, sinkSubmissionTouched :: Any
|
|
, sinkFilenames :: Set FilePath
|
|
} deriving (Show, Eq, Generic, Typeable)
|
|
|
|
instance Monoid SubmissionSinkState where
|
|
mempty = memptydefault
|
|
mappend = mappenddefault
|
|
|
|
data SubmissionSinkException = DuplicateFileTitle FilePath
|
|
| DuplicateRating
|
|
| RatingWithoutUpdate
|
|
| ForeignRating CryptoFileNameSubmission
|
|
deriving (Typeable, Show)
|
|
|
|
instance Exception SubmissionSinkException
|
|
|
|
submissionBlacklist :: [Pattern]
|
|
submissionBlacklist = $(patternFile compDefault "config/submission-blacklist")
|
|
|
|
filterSubmission :: MonadLogger m => ConduitM File File m (Set FilePath)
|
|
-- ^ Removes all `File`s matching `submissionBlacklist`, returning their `fileTitle`s
|
|
filterSubmission = do
|
|
$logDebugS "filterSubmission" $ tshow submissionBlacklist
|
|
execWriterLC . awaitForever $ \case
|
|
File{fileTitle}
|
|
| any (`match'` fileTitle) submissionBlacklist -> tell $ Set.singleton fileTitle
|
|
file -> yield file
|
|
where
|
|
match' = matchWith $ matchDefault
|
|
{ matchDotsImplicitly = True -- Special treatment for . makes no sense since we're multiplatform
|
|
}
|
|
|
|
extractRatings :: ( MonadHandler m
|
|
, HandlerSite m ~ UniWorX
|
|
, MonadCatch m
|
|
, MonadLogger m
|
|
) => ConduitM File SubmissionContent m (Set FilePath)
|
|
extractRatings = filterSubmission `fuseUpstream` Rating.extractRatings
|
|
|
|
extractRatingsMsg :: ( MonadHandler m
|
|
, HandlerSite m ~ UniWorX
|
|
, MonadCatch m
|
|
, MonadLogger m
|
|
) => Conduit File m SubmissionContent
|
|
extractRatingsMsg = do
|
|
ignored <- filterSubmission `fuseUpstream` Rating.extractRatings
|
|
mr <- (toHtml . ) <$> getMessageRender
|
|
addMessage "warning" =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionFilesIgnored.hamlet") mr)
|
|
|
|
sinkSubmission :: UserId
|
|
-> Either SheetId 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 userId mExists isUpdate = do
|
|
sId <- lift $ case mExists of
|
|
Left sheetId -> do
|
|
let
|
|
submissionSheet = sheetId
|
|
submissionRatingPoints = Nothing
|
|
submissionRatingComment = Nothing
|
|
submissionRatingBy = Nothing
|
|
submissionRatingTime = Nothing
|
|
sId <- insert Submission{..}
|
|
-- now <- liftIO getCurrentTime
|
|
-- insert $ SubmissionEdit userId now sId -- This is done automatically during 'sinkSubmission'' iff the given submission is nonempty
|
|
return sId
|
|
Right sId -> return sId
|
|
|
|
sId <$ sinkSubmission' sId 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) $ do
|
|
cID <- encrypt submissionId'
|
|
throwM $ ForeignRating cID
|
|
|
|
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
|
|
]
|
|
|
|
data SubmissionMultiSinkException
|
|
= SubmissionSinkException
|
|
{ submissionSinkId :: CryptoFileNameSubmission
|
|
, submissionSinkFedFile :: Maybe FilePath
|
|
, submissionSinkException :: SubmissionSinkException
|
|
}
|
|
deriving (Typeable, Show)
|
|
|
|
instance Exception SubmissionMultiSinkException
|
|
|
|
sinkMultiSubmission :: UserId
|
|
-> Bool {-^ Are these corrections -}
|
|
-> Sink SubmissionContent (YesodDB 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
|
|
-> StateT
|
|
(Map SubmissionId (ResumableSink SubmissionContent (YesodDB UniWorX) SubmissionId))
|
|
(YesodDB UniWorX)
|
|
()
|
|
feed sId val = do
|
|
mSink <- gets $ Map.lookup sId
|
|
sink <- case mSink of
|
|
Just sink -> return sink
|
|
Nothing -> do
|
|
lift $ do
|
|
Submission{..} <- get404 sId
|
|
cID <- encrypt sId
|
|
Sheet{..} <- get404 submissionSheet
|
|
Course{..} <- get404 sheetCourse
|
|
authRes <- evalAccessDB (CSubmissionR courseTerm courseShorthand sheetName cID CorrectionR) True
|
|
case authRes of
|
|
AuthenticationRequired -> notAuthenticated
|
|
Unauthorized t -> permissionDenied t
|
|
Authorized -> return ()
|
|
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 <- execStateLC Map.empty . awaitForever $ \case
|
|
v@(Right (sId, _)) -> do
|
|
cID <- encrypt sId
|
|
handle (throwM . SubmissionSinkException cID Nothing) $
|
|
lift $ feed sId v
|
|
(Left f@File{..}) -> do
|
|
let
|
|
tryDecrypt :: FilePath -> _ (Either SomeException SubmissionId)
|
|
tryDecrypt (CI.mk -> ciphertext) = try $ decrypt (CryptoID{..} :: CryptoFileNameSubmission)
|
|
acc (Just cID, fp) segment = return (Just cID, fp ++ [segment])
|
|
acc (Nothing , fp) segment = do
|
|
msId <- tryDecrypt segment
|
|
return . either (const id) (set _1 . Just) msId $ (Nothing, fp)
|
|
(msId, (joinPath -> fileTitle')) <- foldM acc (Nothing, []) $ splitDirectories fileTitle
|
|
$logDebugS "sinkMultiSubmission" $ tshow (splitDirectories fileTitle, msId, fileTitle')
|
|
case msId of
|
|
Nothing -> $logDebugS "sinkMultiSubmission" "Dropped"
|
|
Just sId -> do
|
|
cID <- encrypt sId
|
|
handle (throwM . SubmissionSinkException cID (Just fileTitle)) $
|
|
lift . feed sId $ Left f{ fileTitle = fileTitle' }
|
|
fmap Map.keysSet . lift . sequence $ flip Map.mapWithKey sinks $ \sId sink -> do
|
|
cID <- encrypt sId
|
|
handle (throwM . SubmissionSinkException cID Nothing) . void $ closeResumableSink sink
|
|
|
|
submissionMatchesSheet :: TermId -> Text -> Text -> CryptoFileNameSubmission -> DB ()
|
|
submissionMatchesSheet tid csh shn cid = do
|
|
sid <- decrypt cid
|
|
shid <- fetchSheetId tid csh shn
|
|
Submission{..} <- get404 sid
|
|
when (shid /= submissionSheet) $ invalidArgsI [MsgSubmissionWrongSheet]
|