643 lines
36 KiB
Haskell
643 lines
36 KiB
Haskell
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>
|
|
--
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
module Handler.Submission.Helper
|
|
( submissionHelper
|
|
) where
|
|
|
|
import Import
|
|
|
|
import Jobs
|
|
|
|
import Handler.Utils
|
|
import Handler.Utils.Submission
|
|
import Handler.Utils.Invitations
|
|
|
|
import Handler.Submission.Helper.ArchiveTable
|
|
|
|
import Data.Maybe (fromJust)
|
|
|
|
import qualified Database.Esqueleto.Legacy as E
|
|
import qualified Database.Esqueleto.Utils as E
|
|
|
|
import qualified Data.Set as Set
|
|
import Data.Map ((!), (!?))
|
|
import qualified Data.Map as Map
|
|
import qualified Data.Text as Text
|
|
|
|
import Text.Blaze (Markup)
|
|
import qualified Data.Aeson.Types as JSON
|
|
import Data.Aeson.Lens
|
|
|
|
import Handler.Submission.SubmissionUserInvite
|
|
|
|
import qualified Data.Conduit.Combinators as C
|
|
|
|
|
|
makeSubmissionForm :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m)
|
|
=> CourseId -> SheetId -> Maybe (Entity AuthorshipStatementDefinition) -> Maybe SubmissionId -> UploadMode -> SheetGroup -> Maybe FileUploads -> Bool -> Set (Either UserEmail UserId)
|
|
-> (Markup -> MForm (ReaderT SqlBackend m) (FormResult (Maybe FileUploads, Set (Either UserEmail UserId), Maybe AuthorshipStatementDefinitionId), Widget))
|
|
makeSubmissionForm cid shid mASDefinition msmid uploadMode grouping mPrev isLecturer prefillUsers = identifyForm FIDsubmission . renderWForm FormStandard $ do
|
|
uploadRes <- aFormToWForm uploadForm
|
|
submittorsRes <- submittorsForm'
|
|
lecturerIsSubmittor <- case submittorsRes of
|
|
FormSuccess subs -> maybe False ((`Set.member` subs) . Right) <$> maybeAuthId
|
|
_other -> return False
|
|
authorshipStatementRes <- authorshipStatementForm lecturerIsSubmittor
|
|
return $ (,,) <$> uploadRes <*> submittorsRes <*> authorshipStatementRes
|
|
where
|
|
-- TODO(AuthorshipStatements): for lecturer: optionally only invite (co-)submittors instead of adding directly; so they will be forced to make authorship statements
|
|
-- also take care that accepting the invite (optionally) remains possible even after the submission deadline (for creating submissions for course users as a lecturer)
|
|
|
|
authorshipStatementForm :: Bool -> WForm (ReaderT SqlBackend m) (FormResult (Maybe AuthorshipStatementDefinitionId))
|
|
authorshipStatementForm lecturerIsSubmittor = maybeT (return $ FormSuccess Nothing) $ do
|
|
asd <- hoistMaybe mASDefinition
|
|
let authorshipStatementForm' = apopt (acceptAuthorshipStatementField asd) (fslI MsgSubmissionAuthorshipStatement & setTooltip MsgSubmissionAuthorshipStatementTip) Nothing
|
|
authorshipStatementRes <- lift . hoist (hoist liftHandler) $ if
|
|
| isLecturer
|
|
-> optionalActionW authorshipStatementForm' (fslI MsgSubmissionLecturerAuthorshipStatement & setTooltip MsgSubmissionLecturerAuthorshipStatementTip) (Just False)
|
|
| otherwise
|
|
-> fmap Just <$> aFormToWForm authorshipStatementForm'
|
|
if
|
|
| FormSuccess Nothing <- authorshipStatementRes
|
|
, lecturerIsSubmittor -> formFailure [MsgSubmissionLecturerAuthorshipStatementRequiredBecauseSubmittor]
|
|
| otherwise -> return authorshipStatementRes
|
|
|
|
uploadForm :: AForm (ReaderT SqlBackend m) (Maybe FileUploads)
|
|
uploadForm = hoistAForm liftHandler $ if
|
|
| is _NoUpload uploadMode -> pure Nothing
|
|
| is _Nothing msmid -> uploadForm'
|
|
| otherwise -> join <$> optionalActionNegatedA uploadForm' (fslI MsgSubmissionFilesUnchanged & setTooltip MsgSubmissionFilesUnchangedTip) (Just False)
|
|
|
|
uploadForm' = fileUploadForm (not isLecturer) (fslI . bool MsgSubmissionFile MsgSubmissionArchive) uploadMode mPrev
|
|
|
|
miCell' :: Markup -> Either UserEmail UserId -> Widget
|
|
miCell' csrf (Left email) = do
|
|
invWarnMsg <- messageIconI Info IconEmail $ if
|
|
| isLecturer -> MsgEmailInvitationWarningCourseParticipants
|
|
| otherwise -> MsgEmailInvitationWarningPrevCoSubmittors
|
|
$(widgetFile "widgets/massinput/submissionUsers/cellInvitation")
|
|
miCell' csrf (Right uid) = do
|
|
(usr, hasSubmitted) <- liftHandler . runDB $ do
|
|
user <- getJust uid
|
|
hasSubmitted <- E.selectExists . E.from $ \(submissionUser `E.InnerJoin` submission) -> do
|
|
E.on $ submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId
|
|
E.where_ $ submissionUser E.^. SubmissionUserUser E.==. E.val uid
|
|
E.&&. submission E.^. SubmissionSheet E.==. E.val shid
|
|
whenIsJust msmid $ \smid ->
|
|
E.where_ $ submission E.^. SubmissionId E.!=. E.val smid
|
|
return (user, hasSubmitted)
|
|
knownWarning <- runMaybeT $
|
|
guardOnM hasSubmitted $ messageIconI Error IconSubmissionUserDuplicate MsgSubmissionUserDuplicateWarning
|
|
$(widgetFile "widgets/massinput/submissionUsers/cellKnown")
|
|
|
|
miLayout :: ListLength
|
|
-> Map ListPosition (Either UserEmail UserId, FormResult ()) -- ^ massInput state
|
|
-> Map ListPosition Widget -- ^ Cell widgets
|
|
-> Map ListPosition (FieldView UniWorX) -- ^ Deletion buttons
|
|
-> Map (Natural, ListPosition) Widget -- ^ Addition widgets
|
|
-> Widget
|
|
miLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/submissionUsers/layout")
|
|
|
|
miIdent :: Text
|
|
miIdent = "submittors"
|
|
|
|
courseUsers :: E.SqlQuery (E.SqlExpr (Entity User))
|
|
courseUsers = E.from $ \(user `E.InnerJoin` participant) -> do
|
|
E.on $ user E.^. UserId E.==. participant E.^. CourseParticipantUser
|
|
E.where_ $ participant E.^. CourseParticipantCourse E.==. E.val cid
|
|
E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
|
|
E.orderBy [E.asc $ user E.^. UserEmail]
|
|
return user
|
|
previousCoSubmittors :: UserId -> E.SqlQuery (E.SqlExpr (Entity User))
|
|
previousCoSubmittors uid = E.from $ \(user `E.InnerJoin` submissionUser `E.InnerJoin` submission `E.InnerJoin` sheet) -> do
|
|
E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet
|
|
E.&&. sheet E.^. SheetCourse E.==. E.val cid
|
|
E.on $ submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission
|
|
E.on $ user E.^. UserId E.==. submissionUser E.^. SubmissionUserUser
|
|
E.where_ . E.exists . E.from $ \submissionUser' ->
|
|
E.where_ $ submissionUser' E.^. SubmissionUserUser E.==. E.val uid
|
|
E.&&. submissionUser' E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId
|
|
E.where_ . E.exists . E.from $ \participant ->
|
|
E.where_ $ participant E.^. CourseParticipantCourse E.==. E.val cid
|
|
E.&&. participant E.^. CourseParticipantUser E.==. user E.^. UserId
|
|
E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
|
|
E.orderBy [E.asc $ user E.^. UserEmail]
|
|
return user
|
|
|
|
addField :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => UserId -> Field m' (Set (Either UserEmail UserId))
|
|
addField uid = multiUserInvitationField . MUILookupSuggested (SomeMessage MsgMultiUserFieldExplanationPrevCoSubmittors) $ previousCoSubmittors uid
|
|
addFieldLecturer, addFieldAuthorshipStatements :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => Field m' (Set (Either UserEmail UserId))
|
|
addFieldLecturer = multiUserInvitationField $ MUILookupSuggested (SomeMessage MsgMultiUserFieldExplanationCourseParticipants) courseUsers
|
|
addFieldAuthorshipStatements = multiUserInvitationField MUIAlwaysInvite
|
|
|
|
addFieldSettings :: (forall msg. RenderMessage UniWorX msg => msg -> Text) -> FieldSettings UniWorX
|
|
addFieldSettings mr = fslpI MsgSubmissionMembers $ mr MsgLdapIdentificationOrEmail
|
|
submittorSettings, singleSubSettings :: FieldSettings UniWorX
|
|
submittorSettings = fslI MsgSubmissionMembers
|
|
singleSubSettings = fslI MsgSubmissionMember
|
|
|
|
maxSize | Arbitrary{..} <- grouping = Just maxParticipants
|
|
| otherwise = Nothing
|
|
mayEdit = is _Arbitrary grouping
|
|
|
|
submittorSettings'
|
|
| maxSize > Just 1 = submittorSettings
|
|
| otherwise = singleSubSettings
|
|
|
|
miButtonAction' :: forall p. PathPiece p => Maybe (Route UniWorX) -> p -> Maybe (SomeRoute UniWorX)
|
|
miButtonAction' mCurrent frag = mCurrent <&> \current -> SomeRoute (current :#: frag)
|
|
|
|
submittorsForm' :: WForm (ReaderT SqlBackend m) (FormResult (Set (Either UserEmail UserId)))
|
|
submittorsForm' = maybeT submittorsForm $ do
|
|
restr <- MaybeT (liftHandler $ maybeCurrentBearerRestrictions @Value) >>= hoistMaybe . preview (_Object . ix "submittors" . _Array)
|
|
let _Submittor = prism (either toJSON toJSON) $ \x -> first (const x) $ JSON.parseEither (\x' -> fmap Right (parseJSON x') <|> fmap Left (parseJSON x')) x
|
|
submittors <- fmap (pure @FormResult @[Either UserEmail CryptoUUIDUser]) . forM (toList restr) $ hoistMaybe . preview _Submittor
|
|
fmap Set.fromList <$> forMOf (traverse . traverse . _Right) submittors decrypt
|
|
|
|
|
|
submittorsForm :: WForm (ReaderT SqlBackend m) (FormResult (Set (Either UserEmail UserId)))
|
|
submittorsForm
|
|
| isLecturer = do -- Form is being used by lecturer; allow Everything™
|
|
let
|
|
miAdd :: (Text -> Text) -> FieldView UniWorX -> (Markup -> MForm (ReaderT SqlBackend m) (FormResult ([Either UserEmail UserId] -> FormResult [Either UserEmail UserId]), Widget))
|
|
miAdd nudge btn csrf = do
|
|
MsgRenderer mr <- getMsgRenderer
|
|
(addRes, addView) <- mpreq addFieldLecturer (addFieldSettings mr & addName (nudge "emails")) Nothing
|
|
let addRes' = addRes <&> \newData oldData -> if
|
|
| existing <- newData `Set.intersection` Set.fromList oldData
|
|
, not $ Set.null existing
|
|
-> FormFailure [mr MsgSubmissionUserAlreadyAdded]
|
|
| otherwise
|
|
-> FormSuccess $ Set.toList newData
|
|
return (addRes', $(widgetFile "widgets/massinput/submissionUsers/add"))
|
|
|
|
mRoute <- getCurrentRoute
|
|
submittors <- massInputAccumW miAdd (miCell' mempty) (miButtonAction' mRoute) miLayout miIdent submittorSettings True (Just $ Set.toList prefillUsers)
|
|
MsgRenderer mr <- getMsgRenderer
|
|
return $ submittors >>= \submittors' -> if
|
|
| null submittors' -> FormFailure [mr MsgSubmissionUsersEmpty]
|
|
| otherwise -> FormSuccess $ Set.fromList submittors'
|
|
| otherwise = do
|
|
uid <- liftHandler requireAuthId
|
|
mRoute <- getCurrentRoute
|
|
let doAuthorshipStatements = is _Just mASDefinition
|
|
|
|
prefillUsers' <- lift . lift . fmap catMaybes . for (Set.toList prefillUsers) $ \case
|
|
Right uid' | doAuthorshipStatements
|
|
, uid /= uid'
|
|
-> fmap (Left . userEmail) <$> get uid'
|
|
other -> return $ pure other
|
|
|
|
let
|
|
miAdd :: ListPosition
|
|
-> Natural
|
|
-> ListLength
|
|
-> (Text -> Text)
|
|
-> FieldView UniWorX
|
|
-> Maybe (Markup -> MForm (ReaderT SqlBackend m) (FormResult (Map ListPosition (Either UserEmail UserId) -> FormResult (Map ListPosition (Either UserEmail UserId))), Widget))
|
|
miAdd dim pos liveliness nudge btn = guardOn (miAllowAdd dim pos liveliness) $ \csrf -> do
|
|
MsgRenderer mr <- getMsgRenderer
|
|
(addRes, addView) <- if
|
|
| doAuthorshipStatements
|
|
-> mpreq addFieldAuthorshipStatements (addFieldSettings mr & addName (nudge "emails") & setTooltip MsgSubmissionCoSubmittorsInviteRequiredBecauseAuthorshipStatements) Nothing
|
|
| otherwise
|
|
-> mpreq (addField uid) (addFieldSettings mr & addName (nudge "emails")) Nothing
|
|
let addRes' = addRes <&> \newData oldData -> if
|
|
| existing <- newData `Set.intersection` setOf folded oldData
|
|
, not $ Set.null existing
|
|
-> FormFailure [mr MsgSubmissionUserAlreadyAdded]
|
|
| otherwise -> let numStart = maybe 0 (succ . fst) $ Map.lookupMax oldData
|
|
in FormSuccess . Map.fromList . zip [numStart..] $ Set.toList newData
|
|
return (addRes', $(widgetFile "widgets/massinput/submissionUsers/add"))
|
|
|
|
miCell :: ListPosition
|
|
-> Either UserEmail UserId
|
|
-> Maybe ()
|
|
-> (Text -> Text)
|
|
-> (Markup -> MForm (ReaderT SqlBackend m) (FormResult (), Widget))
|
|
miCell _ dat _ _ csrf = return (FormSuccess (), miCell' csrf dat)
|
|
|
|
miDelete :: Map ListPosition (Either UserEmail UserId)
|
|
-> ListPosition
|
|
-> MaybeT (MForm (ReaderT SqlBackend m)) (Map ListPosition ListPosition)
|
|
miDelete dat delPos = do
|
|
guard mayEdit
|
|
guard $ Map.size dat > 1
|
|
|
|
-- User may drop from submission only if it already exists; no directly creating submissions for other people
|
|
guard $ Just (Right uid) /= dat !? delPos || isJust msmid
|
|
|
|
miDeleteList dat delPos
|
|
|
|
miAllowAdd :: ListPosition
|
|
-> Natural
|
|
-> ListLength
|
|
-> Bool
|
|
miAllowAdd _ _ l = mayEdit && maybe False ((l <) . fromIntegral) maxSize
|
|
|
|
miAddEmpty _ _ _ = Set.empty
|
|
|
|
miButtonAction :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)
|
|
miButtonAction = miButtonAction' mRoute
|
|
|
|
postProcess :: Map ListPosition (Either UserEmail UserId, ()) -> Set (Either UserEmail UserId)
|
|
postProcess valMap
|
|
| is _Just msmid
|
|
, resultUsers == prefillUsers
|
|
= resultUsers
|
|
| Just maxSize' <- maxSize
|
|
, fromIntegral maxSize' >= Set.size resultUsers
|
|
= resultUsers
|
|
| Just maxSize' <- maxSize
|
|
= let resultUsers' = Set.take (fromIntegral maxSize') resultUsers
|
|
in if | Set.member (Right uid) resultUsers' -> resultUsers'
|
|
| otherwise -> Set.insert (Right uid) $ Set.take (pred $ fromIntegral maxSize') resultUsers'
|
|
| otherwise = Set.singleton $ Right uid
|
|
where resultUsers = setOf (folded . _1) valMap
|
|
-- when (maxSize > Just 1) $
|
|
-- wformMessage =<< messageI Info MsgCosubmittorTip
|
|
fmap postProcess <$> massInputW MassInput{..} submittorSettings' True (Just . Map.fromList . zip [0..] . map (, ()) $ prefillUsers')
|
|
|
|
submissionHelper :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Maybe CryptoFileNameSubmission -> Handler Html
|
|
submissionHelper tid ssh csh shn mcid = do
|
|
muid <- maybeAuthId
|
|
msmid <- traverse decrypt mcid
|
|
actionUrl <- fromMaybe (error "submissionHelper called from 404-handler") <$> getCurrentRoute
|
|
|
|
let
|
|
getSheetInfo = do
|
|
csheet@(Entity shid Sheet{..}) <- fetchSheet tid ssh csh shn
|
|
mASDefinition <- getSheetAuthorshipStatement csheet
|
|
maySubmit <- (== Authorized) <$> evalAccessDB actionUrl True
|
|
isLecturer <- (== Authorized) <$> evalAccessDB (CSheetR tid ssh csh shn SSubsR) True
|
|
|
|
case (msmid, sheetGrouping) of
|
|
(Nothing, Arbitrary maxBuddies) -> 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` subUser `E.InnerJoin` submissionEdit) -> do
|
|
E.on (submissionEdit E.^. SubmissionEditSubmission E.==. submission E.^. SubmissionId)
|
|
E.on (subUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId)
|
|
E.on (sheet E.^. SheetId E.==. submission E.^. SubmissionSheet)
|
|
E.where_ $ E.just (subUser E.^. SubmissionUserUser) E.==. E.val muid
|
|
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.&&. E.just (submissionUser E.^. SubmissionUserUser) E.!=. E.val muid
|
|
E.orderBy [E.asc $ user E.^. UserEmail]
|
|
return $ user E.^. UserId
|
|
return ( csheet
|
|
, buddies
|
|
& map (Right . E.unValue)
|
|
& Set.fromList
|
|
& assertM' ((<= maxBuddies) . fromIntegral . Set.size . bool id (maybe id (Set.insert . Right) muid) (not isLecturer))
|
|
& fromMaybe Set.empty
|
|
, []
|
|
, maySubmit
|
|
, isLecturer
|
|
, not isLecturer
|
|
, Nothing, Nothing
|
|
, mASDefinition
|
|
)
|
|
(Nothing, RegisteredGroups) -> do
|
|
buddies <- E.select . E.from $ \(submissionGroup `E.InnerJoin` user) -> do
|
|
E.on . E.exists . E.from $ \submissionGroupUser ->
|
|
E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. user E.^. UserId
|
|
E.&&. submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId
|
|
E.where_ $ submissionGroup E.^. SubmissionGroupCourse E.==. E.val sheetCourse
|
|
E.where_ . E.exists . E.from $ \submissionGroupUser ->
|
|
E.where_ $ E.just (submissionGroupUser E.^. SubmissionGroupUserUser) E.==. E.val muid
|
|
E.&&. submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId
|
|
E.where_ $ E.just (user E.^. UserId) E.!=. E.val muid
|
|
E.where_ . E.not_ . E.exists . E.from $ \(submissionUser `E.InnerJoin` submission) -> do
|
|
E.on $ submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId
|
|
E.where_ $ submission E.^. SubmissionSheet E.==. E.val shid
|
|
E.&&. submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId
|
|
|
|
E.orderBy [E.asc $ user E.^. UserEmail]
|
|
|
|
return $ user E.^. UserId
|
|
|
|
return ( csheet
|
|
, buddies
|
|
& map (Right . E.unValue)
|
|
& Set.fromList
|
|
, []
|
|
, maySubmit
|
|
, isLecturer
|
|
, not isLecturer
|
|
, Nothing, Nothing
|
|
, mASDefinition
|
|
)
|
|
(Nothing, _) -> return (csheet, Set.empty, [], maySubmit, isLecturer, not isLecturer, Nothing, Nothing, mASDefinition)
|
|
(Just smid, _) -> do
|
|
void $ submissionMatchesSheet tid ssh csh shn (fromJust mcid)
|
|
|
|
sub@Submission{..} <- get404 smid
|
|
let shid' = submissionSheet
|
|
unless (shid == shid') $
|
|
invalidArgsI [MsgSubmissionWrongSheet]
|
|
-- 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
|
|
let breakUserFromBuddies (E.Value userID)
|
|
| muid == Just userID = (Any True , mempty )
|
|
| otherwise = (mempty , Set.singleton $ Right userID)
|
|
|
|
invites <- sourceInvitationsF smid <&> Set.fromList . map (\(email, InvDBDataSubmissionUser) -> Left email)
|
|
|
|
return . over _2 (Set.union invites) $ foldMap breakUserFromBuddies submittors
|
|
|
|
lastEdits <- do
|
|
raw <- E.select . E.from $ \(user `E.InnerJoin` submissionEdit) -> do
|
|
E.on $ E.just (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
|
|
|
|
corrector <- join <$> traverse getEntity submissionRatingBy
|
|
|
|
return (csheet,buddies,lastEdits,maySubmit,isLecturer,isOwner,Just sub,corrector,mASDefinition)
|
|
|
|
-- @submissionModeUser == Nothing@ below iff we are currently serving a user with elevated rights (lecturer, admin, ...)
|
|
-- Therefore we do not restrict upload behaviour in any way in that case
|
|
((formWidget', formEnctype), mAct) <- runDBJobs . setSerializable $ do
|
|
(Entity shid Sheet{..}, buddies, _, _, isLecturer, isOwner, msubmission, _, mASDefinition) <- hoist lift getSheetInfo
|
|
let mPrevUploads = msmid <&> \smid -> runDBSource $ selectSource [SubmissionFileSubmission ==. smid, SubmissionFileIsUpdate ==. False] [Asc SubmissionFileTitle] .| C.map (view $ _FileReference . _1)
|
|
((res, formWidget'), formEnctype) <- hoist lift . runFormPost . makeSubmissionForm sheetCourse shid mASDefinition msmid (fromMaybe (UploadAny True Nothing True) . submissionModeUser $ sheetSubmissionMode) sheetGrouping mPrevUploads isLecturer $ bool id (maybe id (Set.insert . Right) muid) isOwner buddies
|
|
|
|
-- Calling `msgSubmissionErrors` within a `runDB` is okay as long as we handle `transactionUndo` ourselves iff it returns nothing
|
|
mAct' <- msgSubmissionErrors $ do
|
|
submissions <- E.select . E.from $ \(submission `E.InnerJoin` submissionUser) -> do
|
|
E.on (submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission)
|
|
E.where_ $ E.just (submissionUser E.^. SubmissionUserUser) E.==. E.val muid
|
|
E.&&. submission E.^. SubmissionSheet E.==. E.val shid
|
|
return $ submission E.^. SubmissionId
|
|
case (msmid, submissions) of
|
|
(Nothing, E.Value smid : _) -> do
|
|
cID <- encrypt smid
|
|
addMessageI Info MsgSubmissionAlreadyExists
|
|
redirect $ CSubmissionR tid ssh csh shn cID SubShowR
|
|
_other -> return ()
|
|
|
|
when ( is _Nothing muid
|
|
&& is _Nothing msubmission
|
|
&& not isLecturer
|
|
)
|
|
notAuthenticated
|
|
|
|
-- Determine old submission users
|
|
subUsersOld <- if
|
|
| Just smid <- msmid -> Set.union
|
|
<$> (setOf (folded . _entityVal . _submissionUserUser . to Right) <$> selectList [SubmissionUserSubmission ==. smid] [])
|
|
<*> (sourceInvitationsF smid <&> Set.fromList . map (\(email, InvDBDataSubmissionUser) -> Left email))
|
|
| otherwise -> return Set.empty
|
|
|
|
res' <- case res of
|
|
FormMissing -> return FormMissing
|
|
(FormFailure failmsgs) -> return $ FormFailure failmsgs
|
|
(FormSuccess res'@(_, groupMembers, _))
|
|
| groupMembers == subUsersOld -> return $ FormSuccess res'
|
|
| isLecturer -> return $ FormSuccess res'
|
|
| Arbitrary{..} <- sheetGrouping -> do -- Validate AdHoc Group Members
|
|
let (gEMails, gIds) = partitionEithers $ Set.toList groupMembers
|
|
prep :: [(E.Value UserEmail, (E.Value UserId, E.Value Bool, E.Value Bool))] -> Map UserEmail (Maybe (UserId, Bool, Bool))
|
|
prep ps = 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.^. UserId) `E.in_` E.valList gIds
|
|
let
|
|
isParticipant = E.exists . E.from $ \courseParticipant -> do
|
|
E.where_ $ user E.^. UserId E.==. courseParticipant E.^. CourseParticipantUser
|
|
E.&&. courseParticipant E.^. CourseParticipantCourse E.==. E.val sheetCourse
|
|
hasSubmitted = E.exists . 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 (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 fromIntegral (Map.size participants) `compare` maxParticipants of
|
|
GT | not isLecturer -> pure $ mr MsgTooManyParticipants
|
|
_ -> mempty
|
|
]
|
|
return $ if null failmsgs
|
|
then FormSuccess res'
|
|
else FormFailure failmsgs
|
|
| otherwise -> return $ FormSuccess res'
|
|
|
|
|
|
formResultMaybe res' $ \(mFiles, adhocMembers, mASDId) -> do
|
|
now <- liftIO getCurrentTime
|
|
|
|
smid <- case (mFiles, msmid) of
|
|
(Nothing, Just smid) -- no new files, existing submission partners updated
|
|
-> return smid
|
|
(Just files, _) -> -- new files
|
|
runConduit $ transPipe (lift . lift) files .| extractRatingsMsg .| sinkSubmission muid (maybe (Left shid) Right msmid) False
|
|
(Nothing, Nothing) -- new submission, no file upload requested
|
|
-> do
|
|
sid <- insert Submission
|
|
{ submissionSheet = shid
|
|
, submissionRatingPoints = Nothing
|
|
, submissionRatingComment = Nothing
|
|
, submissionRatingBy = Nothing
|
|
, submissionRatingAssigned = Nothing
|
|
, submissionRatingTime = Nothing
|
|
}
|
|
audit $ TransactionSubmissionEdit sid shid
|
|
|
|
insert_ $ SubmissionEdit muid now sid
|
|
|
|
return sid
|
|
|
|
-- Determine new submission users
|
|
subUsers <- if
|
|
| isLecturer -> return adhocMembers
|
|
| RegisteredGroups <- sheetGrouping -> do
|
|
-- Determine members of pre-registered group
|
|
groupUids <- fmap (setFromList . map (Right . 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_ $ E.just (submissionGroupUser E.^. SubmissionGroupUserUser) E.==. E.val muid
|
|
E.&&. submissionGroup E.^. SubmissionGroupCourse E.==. E.val sheetCourse
|
|
|
|
E.where_ . E.not_ . E.exists . E.from $ \(submissionUser `E.InnerJoin` submission) -> do
|
|
E.on $ submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId
|
|
E.where_ $ submission E.^. SubmissionSheet E.==. E.val shid
|
|
E.&&. submissionUser E.^. SubmissionUserUser E.==. submissionGroupUser' E.^. SubmissionGroupUserUser
|
|
E.where_ $ submission E.^. SubmissionId E.!=. E.val smid
|
|
|
|
return $ submissionGroupUser' E.^. SubmissionGroupUserUser
|
|
-- SubmissionUser for all group members (pre-registered & ad-hoc)
|
|
return $ maybe id (Set.insert . Right) muid groupUids
|
|
| otherwise -> return adhocMembers
|
|
|
|
-- Since invitations carry no data we only need to consider changes to
|
|
-- the set of users/invited emails
|
|
-- Otherwise we would have to update old invitations (via
|
|
-- `sinkInvitationsF`) because their associated @DBData@ might have
|
|
-- changed
|
|
|
|
forM_ (subUsers `setSymmDiff` subUsersOld) $ \change -> if
|
|
-- change is a new user being added to the submission users => send invitation / insert
|
|
| change `Set.member` subUsers -> case change of
|
|
Left subEmail -> do
|
|
-- user does not exist yet => send invitation
|
|
sinkInvitationsF submissionUserInvitationConfig [(subEmail, smid, (InvDBDataSubmissionUser, InvTokenDataSubmissionUser))]
|
|
return ()
|
|
Right subUid -> do
|
|
-- user exists and has an id => insert as SubmissionUser and audit
|
|
insert_ $ SubmissionUser subUid smid
|
|
audit $ TransactionSubmissionUserEdit smid subUid
|
|
unless (Just subUid == muid) $
|
|
queueDBJob . JobQueueNotification $ NotificationSubmissionUserCreated subUid smid
|
|
-- change is an old user that is not a submission user anymore => delete invitation / delete
|
|
| otherwise -> case change of
|
|
Left subEmail -> deleteInvitation @SubmissionUser smid subEmail
|
|
Right subUid -> do
|
|
deleteBy $ UniqueSubmissionUser subUid smid
|
|
audit $ TransactionSubmissionUserDelete smid subUid
|
|
unless (Just subUid == muid) $
|
|
queueDBJob . JobQueueNotification $ NotificationSubmissionUserDeleted subUid shid smid
|
|
|
|
hasAuthorshipStatement <- maybeT (return True) $ do
|
|
uid <- hoistMaybe muid
|
|
asDId <- hoistMaybe mASDId
|
|
lift $ exists [AuthorshipStatementSubmissionStatement ==. asDId, AuthorshipStatementSubmissionSubmission ==. smid, AuthorshipStatementSubmissionUser ==. uid]
|
|
|
|
forM_ mASDId $ \asdId -> do
|
|
uid <- maybe notAuthenticated return muid
|
|
insert_ $ AuthorshipStatementSubmission asdId smid uid now
|
|
|
|
|
|
if | is _Nothing msmid -> addMessageI Success MsgSubmissionCreated
|
|
| is _Just mFiles -> addMessageI Success MsgSubmissionUpdated
|
|
| subUsers == subUsersOld
|
|
, not hasAuthorshipStatement -> addMessageI Success MsgSubmissionUpdatedAuthorshipStatement
|
|
| subUsers == subUsersOld -> addMessageI Info MsgSubmissionUnchanged
|
|
| otherwise -> addMessageI Success MsgSubmissionUsersUpdated
|
|
|
|
cID <- encrypt smid
|
|
let showRoute = CSubmissionR tid ssh csh shn cID SubShowR
|
|
mayShow <- hoist lift $ hasReadAccessTo showRoute
|
|
|
|
return . Just $ if
|
|
| mayShow -> redirect showRoute
|
|
| otherwise -> redirect $ CSheetR tid ssh csh shn SShowR
|
|
|
|
case mAct' of
|
|
Nothing -> ((formWidget', formEnctype), Nothing) <$ E.transactionUndo -- manual rollback because we are calling `msgSubmissionErrors` within a `runDB`
|
|
Just mAct -> return ((formWidget', formEnctype), mAct)
|
|
|
|
sequence_ mAct
|
|
let formWidget = wrapForm' BtnHandIn formWidget' def
|
|
{ formAction = Just $ SomeRoute actionUrl
|
|
, formEncoding = formEnctype
|
|
}
|
|
|
|
((Entity _ Sheet{..}, _, lastEdits, maySubmit, _, _, msubmission, corrector, _), (showCorrection, correctionInvisible), mFileTable, filesCorrected, sheetTypeDesc, multipleSubmissionWarnWidget, (subUsers, subUsersVisible), isLecturer, isOwner, doAuthorshipStatements) <- runDB $ do
|
|
sheetInfo@(Entity shid Sheet{..}, buddies, _, _, isLecturer, isOwner, msubmission, _, mASDefinition) <- getSheetInfo
|
|
|
|
(showCorrection, correctionInvisible) <- fmap (fromMaybe (False, Nothing)) . for ((,) <$> mcid <*> (Entity <$> msmid <*> msubmission)) $ \(cid, subEnt) -> do
|
|
showCorrection <- hasReadAccessTo $ CSubmissionR tid ssh csh shn cid CorrectionR
|
|
correctionInvisible <- correctionInvisibleWidget tid ssh csh shn cid subEnt
|
|
|
|
return (showCorrection, correctionInvisible)
|
|
|
|
-- Maybe construct a table to display uploaded archive files
|
|
mFileTable' <- for msmid $ mkSubmissionArchiveTable tid ssh csh shn showCorrection
|
|
let filesCorrected = maybe False (view _1) mFileTable'
|
|
mFileTable = view _2 <$> mFileTable'
|
|
|
|
sheetTypeDesc <- sheetTypeDescription sheetCourse sheetType
|
|
|
|
multipleSubmissionWarnWidget <- runMaybeT $ do
|
|
subId <- hoistMaybe msmid
|
|
cID <- hoistMaybe mcid
|
|
guardM . lift $ orM
|
|
[ hasWriteAccessTo $ CSubmissionR tid ssh csh shn cID SubDelR
|
|
, hasWriteAccessTo $ CSubmissionR tid ssh csh shn cID SubShowR
|
|
, hasWriteAccessTo $ CSubmissionR tid ssh csh shn cID CorrectionR
|
|
, hasReadAccessTo $ CSheetR tid ssh csh shn SSubsR
|
|
]
|
|
guardM . lift . E.selectExists . E.from $ \(submissionUser `E.InnerJoin` (otherSubmissionUser `E.InnerJoin` submission)) -> do
|
|
E.on $ otherSubmissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId
|
|
E.on $ submissionUser E.^. SubmissionUserSubmission E.!=. otherSubmissionUser E.^. SubmissionUserSubmission
|
|
E.&&. submissionUser E.^. SubmissionUserUser E.==. otherSubmissionUser E.^. SubmissionUserUser
|
|
E.where_ $ submission E.^. SubmissionSheet E.==. E.val shid
|
|
E.&&. submission E.^. SubmissionId E.!=. E.val subId
|
|
E.&&. submissionUser E.^. SubmissionUserSubmission E.==. E.val subId
|
|
return $ notification NotificationBroad =<< messageIconI Warning IconSubmissionUserDuplicate MsgSubmissionSomeUsersDuplicateWarning
|
|
|
|
subUsers <- maybeT (return []) $ do
|
|
subId <- hoistMaybe msmid
|
|
lift $ buddies
|
|
& bool id (maybe id (Set.insert . Right) muid) isOwner
|
|
& Set.toList
|
|
& mapMOf (traverse . _Right) (\uid -> (,,) <$> (encrypt uid :: DB CryptoUUIDUser) <*> getJust uid <*> getUserAuthorshipStatement mASDefinition subId uid)
|
|
& fmap (sortOn . over _Right $ (,,,) <$> views _2 userSurname <*> views _2 userDisplayName <*> views _2 userEmail <*> view _1)
|
|
|
|
subUsersVisible <- orM
|
|
[ return isOwner
|
|
, return isLecturer
|
|
, return $ not sheetAnonymousCorrection
|
|
, hasReadAccessTo $ CSheetR tid ssh csh shn SSubsR
|
|
]
|
|
|
|
return (sheetInfo, (showCorrection, correctionInvisible), mFileTable, filesCorrected, sheetTypeDesc, multipleSubmissionWarnWidget, (subUsers, subUsersVisible), isLecturer, isOwner, is _Just mASDefinition)
|
|
|
|
-- TODO(AuthorshipStatements): discuss whether to display prompt for user to update their authorship statement, if lecturer changed it
|
|
|
|
let (title, heading)
|
|
| Just cID <- mcid, maySubmit, not isLecturer || isOwner = (MsgSubmissionTitle tid ssh csh shn cID, MsgSubmissionHeadingEdit tid ssh csh shn cID)
|
|
| Just cID <- mcid = (MsgSubmissionTitle tid ssh csh shn cID, MsgSubmissionHeadingShow tid ssh csh shn cID)
|
|
| otherwise = (MsgSubmissionTitleNew tid ssh csh shn, MsgSubmissionHeadingNew tid ssh csh shn)
|
|
|
|
siteLayoutMsg heading $ do
|
|
setTitleI title
|
|
(urlArchive, urlOriginal) <- fmap ((,) <$> preview (_Just . _1) <*> preview (_Just . _2)) . for mcid $ \cID
|
|
-> let mkUrl sft = toTextUrl . CSubmissionR tid ssh csh shn cID $ SubArchiveR sft
|
|
in liftHandler . runDB $ (,) <$> mkUrl SubmissionCorrected <*> mkUrl SubmissionOriginal
|
|
tr <- getTranslate
|
|
let correctionWdgt = guardOnM (showCorrection && maybe False submissionRatingTouched msubmission) ((,) <$> msubmission <*> mcid) <&> \(Submission{..}, cid) ->
|
|
let ratingComment = assertM (not . null) $ Text.strip <$> submissionRatingComment
|
|
in $(widgetFile "correction-user")
|
|
where submissionRatingTouched sub@Submission{..} = or
|
|
[ submissionRatingDone sub
|
|
, is _Just submissionRatingPoints, is _Just submissionRatingComment
|
|
]
|
|
correctionVisibleWarnWidget = guardOnM (is _Just msubmission && is _Just mcid && showCorrection) correctionInvisible
|
|
asStatusExplain = $(i18nWidgetFiles "authorship-statement-submission-explanation")
|
|
asStatuses = setOf (folded . _Right . _3) subUsers
|
|
& Set.union (Set.fromList [ASExists, ASMissing])
|
|
& Set.toList
|
|
& mapMaybe (\stmt -> (stmt, ) <$> asStatusExplain Map.!? toPathPiece stmt)
|
|
asStatusExplainWdgt = $(widgetFile "widgets/authorship-statement-submission-explanation")
|
|
$(widgetFile "submission")
|