389 lines
21 KiB
Haskell
389 lines
21 KiB
Haskell
{-# LANGUAGE RecordWildCards, NamedFieldPuns #-}
|
|
{-# LANGUAGE NoImplicitPrelude #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE OverloadedLists #-}
|
|
{-# LANGUAGE ParallelListComp #-}
|
|
{-# LANGUAGE TemplateHaskell #-}
|
|
{-# LANGUAGE QuasiQuotes #-}
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE TupleSections #-}
|
|
{-# LANGUAGE LambdaCase #-}
|
|
{-# LANGUAGE ViewPatterns #-}
|
|
{-# LANGUAGE PatternGuards #-}
|
|
{-# LANGUAGE TypeOperators #-}
|
|
{-# LANGUAGE PartialTypeSignatures #-}
|
|
{-# LANGUAGE MultiWayIf #-}
|
|
|
|
module Handler.Submission where
|
|
|
|
import Import hiding (joinPath)
|
|
|
|
-- import Yesod.Form.Bootstrap3
|
|
|
|
import Handler.Utils
|
|
import Handler.Utils.Table.Cells
|
|
|
|
import Network.Mime
|
|
|
|
import Control.Monad.Trans.Maybe
|
|
import Control.Monad.State.Class
|
|
import Control.Monad.Trans.State.Strict (StateT)
|
|
|
|
import Data.Monoid (Any(..))
|
|
import Data.Maybe (fromJust)
|
|
import qualified Data.Maybe
|
|
import qualified Data.Text as Text
|
|
import qualified Data.Text.Encoding as Text
|
|
|
|
import Data.CaseInsensitive (CI)
|
|
import qualified Data.CaseInsensitive as CI
|
|
|
|
import qualified Database.Esqueleto as E
|
|
import qualified Database.Esqueleto.Internal.Sql as E (unsafeSqlFunction)
|
|
|
|
import qualified Data.Conduit.List as Conduit
|
|
import Data.Conduit.ResumableSink
|
|
|
|
import Data.Set (Set)
|
|
import qualified Data.Set as Set
|
|
import Data.Map (Map)
|
|
import qualified Data.Map as Map
|
|
import Data.Bifunctor
|
|
|
|
import System.FilePath
|
|
|
|
import Colonnade hiding (bool, fromMaybe)
|
|
import qualified Yesod.Colonnade as Yesod
|
|
import qualified Text.Blaze.Html5.Attributes as HA
|
|
|
|
-- DEPRECATED: We always show all edits!
|
|
-- numberOfSubmissionEditDates :: Int64
|
|
-- numberOfSubmissionEditDates = 3 -- for debugging only, should be 1 in production.
|
|
|
|
|
|
makeSubmissionForm :: Maybe SubmissionId -> Bool -> SheetGroup -> [UserEmail] -> Form (Maybe (Source Handler File), [UserEmail])
|
|
makeSubmissionForm msmid unpackZips grouping buddies = identForm FIDsubmission $ \html -> do
|
|
flip (renderAForm FormStandard) html $ (,)
|
|
<$> (bool (\f fs _ -> Just <$> areq f fs Nothing) aopt $ isJust msmid) (zipFileField unpackZips) (fsm $ bool MsgSubmissionFile MsgSubmissionArchive unpackZips) Nothing
|
|
<*> (catMaybes <$> sequenceA [bool aforced' aopt editableBuddies (ciField textField) (fslpI (MsgSubmissionMember g) "user@campus.lmu.de" ) buddy
|
|
| g <- [1..(max groupNr $ length buddies)] -- groupNr might have decreased meanwhile
|
|
| buddy <- map (Just . Just) buddies ++ repeat Nothing -- show current buddies
|
|
])
|
|
<* submitButton
|
|
where
|
|
(groupNr, editableBuddies)
|
|
| Arbitrary{..} <- grouping = (pred maxParticipants, True) -- pred to account for the person submitting
|
|
| otherwise = (0, False)
|
|
|
|
aforced' f fs (Just (Just v)) = Just <$> aforced f fs v
|
|
aforced' _ _ _ = error "Cannot happen since groupNr==0 if grouping/=Arbitrary"
|
|
|
|
getSubmissionNewR, postSubmissionNewR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
|
|
getSubmissionNewR = postSubmissionNewR
|
|
postSubmissionNewR tid ssh csh shn = submissionHelper tid ssh csh shn NewSubmission
|
|
|
|
|
|
getSubShowR, postSubShowR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> Handler Html
|
|
getSubShowR = postSubShowR
|
|
postSubShowR tid ssh csh shn cid = submissionHelper tid ssh csh shn $ ExistingSubmission cid
|
|
|
|
getSubmissionOwnR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
|
|
getSubmissionOwnR tid ssh csh shn = do
|
|
authId <- requireAuthId
|
|
sid <- runDB $ do
|
|
shid <- fetchSheetId tid ssh csh shn
|
|
submissions <- E.select . E.from $ \(submission `E.InnerJoin` submissionUser) -> do
|
|
E.on (submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission)
|
|
E.where_ $ submissionUser E.^. SubmissionUserUser E.==. E.val authId
|
|
E.&&. submission E.^. SubmissionSheet E.==. E.val shid
|
|
return $ submission E.^. SubmissionId
|
|
case submissions of
|
|
((E.Value sid):_) -> return sid
|
|
[] -> notFound
|
|
cID <- encrypt sid
|
|
redirect $ CSubmissionR tid ssh csh shn cID SubShowR
|
|
|
|
submissionHelper :: TermId -> SchoolId -> CourseShorthand -> SheetName -> SubmissionMode -> Handler Html
|
|
submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
|
|
uid <- requireAuthId
|
|
msmid <- traverse decrypt mcid
|
|
actionUrl <- Data.Maybe.fromJust <$> getCurrentRoute
|
|
maySubmit <- (== Authorized) <$> isAuthorized actionUrl True -- affects visibility of Edit-Dates, Submission-Button, etc.
|
|
|
|
(Entity shid Sheet{..}, buddies, lastEdits) <- runDB $ do
|
|
sheet@(Entity shid Sheet{..}) <- fetchSheet tid ssh csh shn
|
|
case msmid of
|
|
Nothing -> do
|
|
submissions <- E.select . E.from $ \(submission `E.InnerJoin` submissionUser) -> do
|
|
E.on (submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission)
|
|
E.where_ $ submissionUser E.^. SubmissionUserUser E.==. E.val uid
|
|
E.&&. submission E.^. SubmissionSheet E.==. E.val shid
|
|
return $ submission E.^. SubmissionId
|
|
-- $logDebugS "Submission.DUPLICATENEW" (tshow submissions)
|
|
case submissions of
|
|
[] -> do
|
|
-- fetch buddies from previous submission in this course
|
|
buddies <- E.select . E.from $ \(submissionUser `E.InnerJoin` user) -> do
|
|
E.on (submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId)
|
|
let oldids = E.subList_select . E.from $ \(sheet `E.InnerJoin` submission `E.InnerJoin` submissionUser `E.InnerJoin` submissionEdit) -> do
|
|
E.on (submissionEdit E.^. SubmissionEditSubmission E.==. submission E.^. SubmissionId)
|
|
E.on (submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId)
|
|
E.on (sheet E.^. SheetId E.==. submission E.^. SubmissionSheet)
|
|
E.where_ $ submissionUser E.^. SubmissionUserUser E.==. E.val uid
|
|
E.&&. sheet E.^. SheetCourse E.==. E.val sheetCourse
|
|
E.orderBy [E.desc $ submissionEdit E.^. SubmissionEditTime]
|
|
E.limit 1
|
|
return $ submission E.^. SubmissionId
|
|
E.where_ $ submissionUser E.^. SubmissionUserSubmission `E.in_` oldids
|
|
E.&&. submissionUser E.^. SubmissionUserUser E.!=. E.val uid
|
|
E.orderBy [E.asc $ user E.^. UserEmail]
|
|
return $ user E.^. UserEmail
|
|
return (sheet, map E.unValue buddies, [])
|
|
(E.Value smid:_) -> do
|
|
cID <- encrypt smid
|
|
addMessageI "info" $ MsgSubmissionAlreadyExists
|
|
redirect $ CSubmissionR tid ssh csh shn cID SubShowR
|
|
(Just smid) -> do
|
|
void $ submissionMatchesSheet tid ssh csh shn (fromJust mcid)
|
|
|
|
shid' <- submissionSheet <$> get404 smid
|
|
-- fetch buddies from current submission
|
|
(Any isOwner, buddies) <- do
|
|
submittors <- E.select . E.from $ \(submissionUser `E.InnerJoin` user) -> do
|
|
E.on (submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId)
|
|
E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val smid
|
|
E.orderBy [E.asc $ user E.^. UserEmail]
|
|
return $ (user E.^. UserId, user E.^. UserEmail)
|
|
let breakUserFromBuddies (E.Value userID, E.Value email)
|
|
| uid == userID = (Any True , [])
|
|
| otherwise = (Any False, [email])
|
|
return $ foldMap breakUserFromBuddies submittors
|
|
|
|
lastEdits <- do
|
|
raw <- E.select . E.from $ \(user `E.InnerJoin` submissionEdit) -> do
|
|
E.on (user E.^. UserId E.==. submissionEdit E.^. SubmissionEditUser)
|
|
E.where_ $ submissionEdit E.^. SubmissionEditSubmission E.==. E.val smid
|
|
E.orderBy [E.desc $ submissionEdit E.^. SubmissionEditTime]
|
|
-- E.limit numberOfSubmissionEditDates -- DEPRECATED we always show all edit times
|
|
let userName = if isOwner || maySubmit
|
|
then E.just $ user E.^. UserDisplayName
|
|
else E.nothing
|
|
return $ (userName, submissionEdit E.^. SubmissionEditTime)
|
|
forM raw $ \(E.Value name, E.Value time) -> (name, ) <$> formatTime SelFormatDateTime time
|
|
return (sheet,buddies,lastEdits)
|
|
let unpackZips = True -- undefined -- TODO
|
|
((res,formWidget), formEnctype) <- runFormPost $ makeSubmissionForm msmid unpackZips sheetGrouping buddies
|
|
mCID <- runDB $ do
|
|
res' <- case res of
|
|
(FormMissing ) -> return $ FormMissing
|
|
(FormFailure failmsgs) -> return $ FormFailure failmsgs
|
|
(FormSuccess (mFiles,[])) -> return $ FormSuccess (mFiles,[]) -- Type change
|
|
(FormSuccess (mFiles,gEMails@(_:_))) -- Validate AdHoc Group Members
|
|
| (Arbitrary {..}) <- sheetGrouping -> do
|
|
-- , length gEMails < maxParticipants -> do -- < since submitting user is already accounted for
|
|
let prep :: [(E.Value UserEmail, (E.Value UserId, E.Value Bool, E.Value Bool))] -> Map (CI Text) (Maybe (UserId, Bool, Bool))
|
|
prep ps = Map.filter (maybe True $ \(i,_,_) -> i /= uid) . Map.fromList $ map (, Nothing) gEMails ++ [(m, Just (i,p,s))|(E.Value m, (E.Value i, E.Value p, E.Value s)) <- ps]
|
|
participants <- fmap prep . E.select . E.from $ \user -> do
|
|
E.where_ $ (user E.^. UserEmail) `E.in_` E.valList gEMails
|
|
let
|
|
isParticipant = E.sub_select . E.from $ \courseParticipant -> do
|
|
E.where_ $ user E.^. UserId E.==. courseParticipant E.^. CourseParticipantUser
|
|
E.&&. courseParticipant E.^. CourseParticipantCourse E.==. E.val sheetCourse
|
|
return $ E.countRows E.>. E.val (0 :: Int64)
|
|
hasSubmitted = E.sub_select . E.from $ \(submissionUser `E.InnerJoin` submission) -> do
|
|
E.on $ submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId
|
|
E.where_ $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId
|
|
E.&&. submission E.^. SubmissionSheet E.==. E.val shid
|
|
case msmid of -- Multiple `E.where_`-Statements are merged with `&&` in esqueleto 2.5.3
|
|
Nothing -> return ()
|
|
Just smid -> E.where_ $ submission E.^. SubmissionId E.!=. E.val smid
|
|
return $ E.countRows E.>. E.val (0 :: Int64)
|
|
return (user E.^. UserEmail, (user E.^. UserId, isParticipant, hasSubmitted))
|
|
|
|
$logDebugS "SUBMISSION.AdHocGroupValidation" $ tshow participants
|
|
|
|
mr <- getMessageRender
|
|
let
|
|
failmsgs = (concat :: [[Text]] -> [Text])
|
|
[ flip Map.foldMapWithKey participants $ \email -> \case
|
|
Nothing -> pure . mr $ MsgEMailUnknown email
|
|
(Just (_,False,_)) -> pure . mr $ MsgNotAParticipant email tid csh
|
|
(Just (_,_, True)) -> pure . mr $ MsgSubmissionAlreadyExistsFor email
|
|
_other -> mempty
|
|
, case length participants `compare` maxParticipants of
|
|
LT -> mempty
|
|
_ -> pure $ mr MsgTooManyParticipants
|
|
]
|
|
return $ if null failmsgs
|
|
then FormSuccess (mFiles, foldMap (\(Just (i,_,_)) -> [i]) participants)
|
|
else FormFailure failmsgs
|
|
| otherwise -> return $ FormFailure ["Mismatching number of group participants"]
|
|
|
|
|
|
case res' of
|
|
(FormSuccess (mFiles,(setFromList -> adhocIds))) -> do
|
|
now <- liftIO $ getCurrentTime
|
|
smid <- do
|
|
smid <- case (mFiles, msmid) of
|
|
(Nothing, Just smid) -- no new files, existing submission partners updated
|
|
-> return smid
|
|
(Just files, _) -- new files
|
|
-> runConduit $ transPipe lift files .| extractRatingsMsg .| sinkSubmission uid (maybe (Left shid) Right msmid) False
|
|
_ -> error "Impossible, because of definition of `makeSubmissionForm`"
|
|
-- Determine members of pre-registered group
|
|
groupUids <- fmap (setFromList . map E.unValue) . E.select . E.from $ \(submissionGroupUser `E.InnerJoin` submissionGroup `E.InnerJoin` submissionGroupUser') -> do
|
|
E.on $ submissionGroup E.^. SubmissionGroupId E.==. submissionGroupUser' E.^. SubmissionGroupUserSubmissionGroup
|
|
E.on $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId
|
|
E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. E.val uid
|
|
E.&&. submissionGroup E.^. SubmissionGroupCourse E.==. E.val sheetCourse
|
|
return $ submissionGroupUser' E.^. SubmissionGroupUserUser
|
|
-- SubmissionUser for all group members (pre-registered & ad-hoc)
|
|
let subUsers = Set.insert uid $ groupUids `Set.union` adhocIds
|
|
-- remove obsolete old entries
|
|
deleteWhere [SubmissionUserSubmission ==. smid, SubmissionUserUser /<-. setToList subUsers]
|
|
-- maybe add current users
|
|
forM_ subUsers $ \uid' -> void . insertUnique $ SubmissionUser uid' smid
|
|
return smid
|
|
cID <- encrypt smid
|
|
return $ Just cID
|
|
(FormFailure msgs) -> Nothing <$ forM_ msgs (addMessage "warning" . toHtml)
|
|
_other -> return Nothing
|
|
|
|
case mCID of
|
|
Just cID -> redirect $ CSubmissionR tid ssh csh shn cID SubShowR
|
|
Nothing -> return ()
|
|
|
|
-- Maybe construct a table to display uploaded archive files
|
|
let colonnadeFiles :: _ -> Colonnade Sortable _ (DBCell (HandlerT UniWorX IO) ())
|
|
colonnadeFiles cid = mconcat
|
|
[ sortable (Just "path") (textCell MsgFileTitle) $ \(coalesce -> (mOrig, mCorr)) -> let
|
|
Just fileTitle' = fileTitle . entityVal . snd <$> (mOrig <|> mCorr)
|
|
origIsFile = fmap (isJust . fileContent . entityVal . snd) mOrig
|
|
corrIsFile = fmap (isJust . fileContent . entityVal . snd) mCorr
|
|
Just isFile = origIsFile <|> corrIsFile
|
|
in if
|
|
| Just True <- origIsFile -> anchorCell (CSubmissionR tid ssh csh shn cid $ SubDownloadR SubmissionOriginal fileTitle')
|
|
([whamlet|#{fileTitle'}|])
|
|
| otherwise -> textCell $ bool (<> "/") id isFile fileTitle'
|
|
, sortable (toNothing "state") (i18nCell MsgCorState) $ \(coalesce -> (_, mCorr)) -> case mCorr of
|
|
Nothing -> cell mempty
|
|
Just (_, Entity _ File{..})
|
|
| isJust fileContent -> anchorCell (CSubmissionR tid ssh csh shn cid $ SubDownloadR SubmissionCorrected fileTitle)
|
|
([whamlet|_{MsgFileCorrected}|])
|
|
| otherwise -> textCell MsgCorrected
|
|
, sortable (Just "time") (textCell MsgFileModified) $ \(coalesce -> (mOrig, mCorr)) -> let
|
|
origTime = fileModified . entityVal . snd <$> mOrig
|
|
corrTime = fileModified . entityVal . snd <$> mCorr
|
|
Just fileTime = (max <$> origTime <*> corrTime) <|> origTime <|> corrTime
|
|
in timeCell fileTime
|
|
]
|
|
coalesce :: ((Maybe (Entity SubmissionFile), Maybe (Entity File)), (Maybe (Entity SubmissionFile), Maybe (Entity File))) -> (Maybe (Entity SubmissionFile, Entity File), Maybe (Entity SubmissionFile, Entity File))
|
|
coalesce ((ma, mb), (mc, md)) = ((,) <$> ma <*> mb, (,) <$> mc <*> md)
|
|
submissionFiles :: _ -> _ -> E.SqlQuery _
|
|
submissionFiles smid ((sf1 `E.InnerJoin` f1) `E.FullOuterJoin` (sf2 `E.InnerJoin` f2)) = do
|
|
E.on $ f2 E.?. FileId E.==. sf2 E.?. SubmissionFileFile
|
|
E.on $ f1 E.?. FileTitle E.==. f2 E.?. FileTitle
|
|
E.&&. sf1 E.?. SubmissionFileSubmission E.==. sf2 E.?. SubmissionFileSubmission
|
|
E.&&. sf1 E.?. SubmissionFileId E.!=. sf2 E.?. SubmissionFileId
|
|
E.on $ f1 E.?. FileId E.==. sf1 E.?. SubmissionFileFile
|
|
|
|
E.where_ $ (sf1 E.?. SubmissionFileIsUpdate E.==. E.val (Just False) E.||. E.isNothing (sf1 E.?. SubmissionFileIsUpdate))
|
|
E.&&. (sf2 E.?. SubmissionFileIsUpdate E.==. E.val (Just True) E.||. E.isNothing (sf2 E.?. SubmissionFileIsUpdate))
|
|
E.&&. (sf1 E.?. SubmissionFileSubmission E.==. E.val (Just smid) E.||. sf2 E.?. SubmissionFileSubmission E.==. E.val (Just smid))
|
|
|
|
return ((sf1, f1), (sf2, f2))
|
|
smid2ArchiveTable (smid,cid) = DBTable
|
|
{ dbtSQLQuery = submissionFiles smid
|
|
, dbtColonnade = colonnadeFiles cid
|
|
, dbtProj = return . dbrOutput
|
|
, dbtStyle = def
|
|
, dbtIdent = "files" :: Text
|
|
, dbtSorting = [ ( "path"
|
|
, SortColumn $ \((sf1 `E.InnerJoin` f1) `E.FullOuterJoin` (sf2 `E.InnerJoin` f2)) -> E.coalesce [f1 E.?. FileTitle, f2 E.?. FileTitle]
|
|
)
|
|
, ( "time"
|
|
, SortColumn $ \((sf1 `E.InnerJoin` f1) `E.FullOuterJoin` (sf2 `E.InnerJoin` f2)) -> (E.unsafeSqlFunction "GREATEST" ([f1 E.?. FileModified, f2 E.?. FileModified] :: [E.SqlExpr (E.Value (Maybe UTCTime))]) :: E.SqlExpr (E.Value (Maybe UTCTime)))
|
|
)
|
|
]
|
|
, dbtFilter = []
|
|
}
|
|
mFileTable <- traverse (fmap snd . dbTable def) . fmap smid2ArchiveTable $ (,) <$> msmid <*> mcid
|
|
|
|
defaultLayout $ do
|
|
setTitleI $ MsgSubmissionEditHead tid ssh csh shn
|
|
let urlArchive cID = CSubmissionR tid ssh csh shn cID (SubArchiveR (ZIPArchiveName SubmissionCorrected))
|
|
urlOriginal cID = CSubmissionR tid ssh csh shn cID (SubArchiveR (ZIPArchiveName SubmissionOriginal))
|
|
$(widgetFile "submission")
|
|
|
|
|
|
getSubDownloadR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> SubmissionFileType -> FilePath -> Handler TypedContent
|
|
getSubDownloadR tid ssh csh shn cID (submissionFileTypeIsUpdate -> isUpdate) path = do
|
|
runDB $ do
|
|
submissionID <- submissionMatchesSheet tid ssh csh shn cID
|
|
|
|
isRating <- maybe False (== submissionID) <$> isRatingFile path
|
|
|
|
when (isUpdate || isRating) $
|
|
guardAuthResult =<< evalAccessDB (CSubmissionR tid ssh csh shn cID CorrectionR) False
|
|
|
|
case isRating of
|
|
True
|
|
| isUpdate -> do
|
|
file <- runMaybeT $ lift . ratingFile cID =<< MaybeT (getRating submissionID)
|
|
maybe notFound (return . toTypedContent . Text.decodeUtf8) $ fileContent =<< file
|
|
| otherwise -> notFound
|
|
False -> do
|
|
results <- E.select . E.from $ \(sf `E.InnerJoin` f) -> do
|
|
E.on (f E.^. FileId E.==. sf E.^. SubmissionFileFile)
|
|
E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionID
|
|
E.&&. f E.^. FileTitle E.==. E.val path
|
|
E.&&. E.not_ (sf E.^. SubmissionFileIsDeletion)
|
|
E.&&. sf E.^. SubmissionFileIsUpdate E.==. E.val isUpdate
|
|
-- E.&&. E.not_ (E.isNothing $ f E.^. FileContent) -- This is fine, we just return 204
|
|
return f
|
|
|
|
let fileName = Text.pack $ takeFileName path
|
|
case results of
|
|
[Entity _ File{ fileContent = Just c, fileTitle }] -> do
|
|
whenM downloadFiles $
|
|
addHeader "Content-Disposition" [st|attachment; filename="#{takeFileName fileTitle}"|]
|
|
return $ TypedContent (defaultMimeLookup (pack fileTitle) <> "; charset=utf-8") (toContent c)
|
|
[Entity _ File{ fileContent = Nothing }] -> sendResponseStatus noContent204 ()
|
|
other -> do
|
|
$logErrorS "SubDownloadR" $ "Multiple matching files: " <> tshow other
|
|
error "Multiple matching files found."
|
|
|
|
getSubArchiveR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> ZIPArchiveName SubmissionFileType -> Handler TypedContent
|
|
getSubArchiveR tid ssh csh shn cID (ZIPArchiveName sfType) = do
|
|
when (sfType == SubmissionCorrected) $
|
|
guardAuthResult =<< evalAccess (CSubmissionR tid ssh csh shn cID CorrectionR) False
|
|
|
|
let filename
|
|
| SubmissionOriginal <- sfType = ZIPArchiveName $ toPathPiece cID <> "-" <> toPathPiece sfType
|
|
| otherwise = ZIPArchiveName $ toPathPiece cID
|
|
|
|
addHeader "Content-Disposition" [st|attachment; filename="#{toPathPiece filename}"|]
|
|
respondSourceDB "application/zip" $ do
|
|
submissionID <- lift $ submissionMatchesSheet tid ssh csh shn cID
|
|
rating <- lift $ getRating submissionID
|
|
|
|
let
|
|
fileSource = case sfType of
|
|
SubmissionOriginal -> E.selectSource . E.from $ \(sf `E.InnerJoin` f) -> do
|
|
E.on $ f E.^. FileId E.==. sf E.^. SubmissionFileFile
|
|
E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionID
|
|
E.&&. sf E.^. SubmissionFileIsUpdate E.==. E.val False
|
|
return f
|
|
_ -> submissionFileSource submissionID
|
|
|
|
fileSource' = do
|
|
fileSource .| Conduit.map entityVal
|
|
when (sfType == SubmissionCorrected) $
|
|
maybe (return ()) (yieldM . ratingFile cID) rating
|
|
|
|
zipComment = Text.encodeUtf8 $ toPathPiece cID
|
|
|
|
fileSource' .| produceZip ZipInfo{..} .| Conduit.map toFlushBuilder
|