84 lines
3.2 KiB
Haskell
84 lines
3.2 KiB
Haskell
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>
|
|
--
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
module Handler.Submission.Upload
|
|
( getCorrectionsUploadR, postCorrectionsUploadR
|
|
) where
|
|
|
|
import Import hiding (link)
|
|
-- import System.FilePath (takeFileName)
|
|
|
|
import Jobs
|
|
import Handler.Utils hiding (colSchool)
|
|
import Handler.Utils.Submission
|
|
|
|
import qualified Data.Set as Set
|
|
|
|
import Data.List (genericLength)
|
|
|
|
import qualified Data.Conduit.List as C
|
|
|
|
|
|
data SubmissionDoneMode
|
|
= SubmissionDoneNever
|
|
| SubmissionDoneByFile
|
|
| SubmissionDoneAlways
|
|
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic)
|
|
deriving anyclass (Universe, Finite)
|
|
nullaryPathPiece ''SubmissionDoneMode $ camelToPathPiece' 2
|
|
embedRenderMessage ''UniWorX ''SubmissionDoneMode id
|
|
|
|
|
|
explainSubmissionDoneMode :: SubmissionDoneMode -> MaybeT Handler Widget
|
|
explainSubmissionDoneMode SubmissionDoneNever = return $(i18nWidgetFile "submission-done-tip/never")
|
|
explainSubmissionDoneMode SubmissionDoneAlways = return $(i18nWidgetFile "submission-done-tip/always")
|
|
explainSubmissionDoneMode SubmissionDoneByFile = return $(i18nWidgetFile "submission-done-tip/by-file")
|
|
|
|
|
|
getCorrectionsUploadR, postCorrectionsUploadR :: Handler Html
|
|
getCorrectionsUploadR = postCorrectionsUploadR
|
|
postCorrectionsUploadR = do
|
|
((uploadRes, upload), uploadEncoding) <- runFormPost . identifyForm FIDcorrectionsUpload . renderAForm FormStandard $ (,)
|
|
<$> areq (zipFileField True Nothing True) (fslI MsgCorrUploadField) Nothing
|
|
<*> apopt (explainedSelectionField Nothing $ explainOptionList optionsFinite explainSubmissionDoneMode) (fslI MsgCorrUploadSubmissionDoneMode & setTooltip MsgCorrUploadSubmissionDoneModeTip) (Just SubmissionDoneByFile)
|
|
|
|
formResult uploadRes $ \(files, doneMode) -> do
|
|
let
|
|
setDone (Right (subId, rating))
|
|
= Right ( subId
|
|
, rating & _ratingDone %~ setDone'
|
|
)
|
|
where setDone' = case doneMode of
|
|
SubmissionDoneNever -> const False
|
|
SubmissionDoneByFile -> id
|
|
SubmissionDoneAlways -> const True
|
|
setDone other = other
|
|
|
|
uid <- requireAuthId
|
|
mbSubs <- msgSubmissionErrors . runDBJobs . runConduit $
|
|
transPipe (lift . lift) files
|
|
.| extractRatingsMsg
|
|
.| C.map setDone
|
|
.| sinkMultiSubmission uid True
|
|
|
|
forM_ mbSubs $ \subs -> if
|
|
| null subs -> addMessageI Warning MsgNoCorrectionsUploaded
|
|
| otherwise -> do
|
|
subs' <- traverse (\x -> (,) <$> encrypt x <*> encrypt x) $ Set.toList subs :: Handler [(CryptoFileNameSubmission, CryptoUUIDSubmission)]
|
|
let trigger = [whamlet|_{MsgCorrectionsUploaded (genericLength subs')}|]
|
|
content = Right $(widgetFile "messages/correctionsUploaded")
|
|
addMessageModal Success trigger content
|
|
redirect CorrectionsR
|
|
|
|
let uploadForm = wrapForm upload def
|
|
{ formAction = Just $ SomeRoute CorrectionsUploadR
|
|
, formEncoding = uploadEncoding
|
|
}
|
|
|
|
maxUploadMB <- appMaximumContentLength <$> getsYesod appSettings'
|
|
|
|
defaultLayout $ do
|
|
let uploadInstruction = $(i18nWidgetFile "corrections-upload-instructions")
|
|
$(widgetFile "corrections-upload")
|