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 data AuthorshipStatementSubmissionState = ASOkay | ASOldStatement | ASMissing deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) deriving anyclass (Universe, Finite) nullaryPathPiece ''AuthorshipStatementSubmissionState $ camelToPathPiece' 1 embedRenderMessage ''UniWorX ''AuthorshipStatementSubmissionState $ concat . ("SubmissionAuthorshipStatementState" :) . drop 1 . splitCamel 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 (User{..}, 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 E.&&. courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive 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, isLecturer, 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 let getUserAuthorshipStatement :: UserId -> DB AuthorshipStatementSubmissionState getUserAuthorshipStatement uid = runConduit $ getStmts .| fmap toRes (execWriterC . C.mapM_ $ tell . toPoint) where getStmts = E.selectSource . E.from $ \authorshipStatementSubmission -> do E.where_ $ authorshipStatementSubmission E.^. AuthorshipStatementSubmissionSubmission E.==. E.val subId E.&&. authorshipStatementSubmission E.^. AuthorshipStatementSubmissionUser E.==. E.val uid return authorshipStatementSubmission toPoint :: Entity AuthorshipStatementSubmission -> Maybe Any toPoint (Entity _ AuthorshipStatementSubmission{..}) = Just . Any $ fmap entityKey mASDefinition == Just authorshipStatementSubmissionStatement toRes :: Maybe Any -> AuthorshipStatementSubmissionState toRes = \case Just (Any True) -> ASOkay Just (Any False) -> ASOldStatement Nothing -> ASMissing lift $ buddies & bool id (maybe id (Set.insert . Right) muid) isOwner & Set.toList & mapMOf (traverse . _Right) (\uid -> (,,) <$> (encrypt uid :: DB CryptoUUIDUser) <*> getJust uid <*> getUserAuthorshipStatement uid) & fmap (sortOn . over _Right $ (,,,) <$> views _2 userSurname <*> views _2 userDisplayName <*> views _2 userEmail <*> view _1) return (sheetInfo, (showCorrection, correctionInvisible), mFileTable, filesCorrected, sheetTypeDesc, multipleSubmissionWarnWidget, subUsers, isLecturer, is _Just mASDefinition) -- TODO(AuthorshipStatements): discuss whether to display prompt for user to update their authorship statement, if lecturer changed it defaultLayout $ do setTitleI $ MsgHeadingSubmissionEditHead tid ssh csh shn (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 [ASOkay, ASMissing]) & Set.toList & mapMaybe (\stmt -> (stmt, ) <$> asStatusExplain Map.!? toPathPiece stmt) $(widgetFile "submission")