diff --git a/src/Audit/Types.hs b/src/Audit/Types.hs index a4e80d6e7..7607a9828 100644 --- a/src/Audit/Types.hs +++ b/src/Audit/Types.hs @@ -53,7 +53,6 @@ data Transaction , transactionCourseApplication :: CourseApplicationId } - -- TODO: audit work in progress | TransactionSubmissionEdit { transactionSubmission :: SubmissionId , transactionSheet :: SheetId diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index b73981bfe..b77e8c5f3 100644 --- a/src/Handler/Submission.hs +++ b/src/Handler/Submission.hs @@ -409,7 +409,8 @@ submissionHelper tid ssh csh shn mcid = do (Just files, _) -> -- new files runConduit $ transPipe (lift . lift) files .| extractRatingsMsg .| sinkSubmission uid (maybe (Left shid) Right msmid) False (Nothing, Nothing) -- new submission, no file upload requested - -> insert Submission + -> do + sid <- insert Submission { submissionSheet = shid , submissionRatingPoints = Nothing , submissionRatingComment = Nothing @@ -417,6 +418,10 @@ submissionHelper tid ssh csh shn mcid = do , submissionRatingAssigned = Nothing , submissionRatingTime = Nothing } + audit $ TransactionSubmissionEdit sid shid + return sid + + -- Determine new submission users subUsers <- if | isLecturer -> return adhocMembers | otherwise -> do @@ -429,12 +434,30 @@ submissionHelper tid ssh csh shn mcid = do return $ submissionGroupUser' E.^. SubmissionGroupUserUser -- SubmissionUser for all group members (pre-registered & ad-hoc) return $ groupUids `Set.union` adhocMembers - let (subEmails, subUids) = partitionEithers $ Set.toList subUsers - deleteWhere [SubmissionUserSubmission ==. smid] - deleteWhere [InvitationFor ==. invRef @SubmissionUser smid, InvitationEmail /<-. subEmails] - insertMany_ $ map (flip SubmissionUser smid) subUids - sinkInvitationsF submissionUserInvitationConfig $ map (\lEmail -> (lEmail, smid, (InvDBDataSubmissionUser, InvTokenDataSubmissionUser))) subEmails + -- Determine old submission users + subUsersOld <- if + | isJust msmid -> setOf (folded . _entityVal . _submissionUserUser . to Right) <$> selectList [SubmissionUserSubmission ==. smid] [] + | otherwise -> return Set.empty -- optimization (do not perform selection if submission was freshly created) + + 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 + -- change is an old user that is not a submission user anymore => delete invitation / delete + | otherwise -> case change of + Left subEmail -> runConduit $ yield subEmail .| deleteInvitations @SubmissionUser smid + Right subUid -> do + deleteWhere [SubmissionUserUser ==. subUid] + audit $ TransactionSubmissionUserDelete smid subUid + addMessageI Success $ if | Nothing <- msmid -> MsgSubmissionCreated | otherwise -> MsgSubmissionUpdated return smid diff --git a/src/Handler/Utils/Invitations.hs b/src/Handler/Utils/Invitations.hs index 94740d96c..4c9c35ad2 100644 --- a/src/Handler/Utils/Invitations.hs +++ b/src/Handler/Utils/Invitations.hs @@ -11,6 +11,7 @@ module Handler.Utils.Invitations , InvitationReference(..), invRef , InvitationConfig(..), InvitationTokenConfig(..) , sourceInvitations, sourceInvitationsList + , deleteInvitations , sinkInvitations, sinkInvitationsF , invitationR', InvitationR(..) ) where @@ -28,6 +29,7 @@ import Control.Monad.Trans.Reader (mapReaderT) import qualified Data.Conduit.List as C import qualified Data.List.NonEmpty as NonEmpty import qualified Data.HashSet as HashSet +import qualified Data.Set as Set import Data.Aeson (fromJSON) import qualified Data.Aeson as JSON @@ -257,6 +259,18 @@ sourceInvitationsList :: forall junction. sourceInvitationsList forKey = runConduit $ sourceInvitations forKey .| C.foldMap pure +-- | Deletes all invitations for given emails and a given junction. (Type application required) +deleteInvitations :: forall junction m. + ( IsInvitableJunction junction + , MonadIO m + ) + => Key (InvitationFor junction) + -> Sink UserEmail (ReaderT SqlBackend m) () +deleteInvitations k = do + subEmails <- C.foldMap Set.singleton + lift $ deleteWhere [InvitationEmail <-. Set.toList subEmails, InvitationFor ==. invRef @junction k] + + data ButtonInvite = BtnInviteAccept | BtnInviteDecline deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) instance Universe ButtonInvite diff --git a/src/Utils.hs b/src/Utils.hs index 7bea6fcd0..8b0c17333 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -395,6 +395,10 @@ setIntersections (h:t) = foldl' Set.intersection h t setMapMaybe :: (Ord a, Ord b) => (a -> Maybe b) -> Set a -> Set b setMapMaybe f = Set.fromList . mapMaybe f . Set.toList +-- | Symmetric difference of two sets. +setSymmDiff :: Ord a => Set a -> Set a -> Set a +setSymmDiff x y = (x `Set.difference` y) `Set.union` (y `Set.difference` x) + ---------- -- Maps -- ---------- diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index 690360591..a692f37ee 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -169,6 +169,8 @@ makeLenses_ ''File makeLenses_ ''Submission +makeLenses_ ''SubmissionUser + -- makeClassy_ ''Load