chore(audit): audit submissionhelper

src/Audit/Types.hs

@@ -53,7 +53,6 @@ data Transaction
     , transactionCourseApplication :: CourseApplicationId
     }
 
-  -- TODO: audit work in progress
   | TransactionSubmissionEdit
     { transactionSubmission :: SubmissionId
     , transactionSheet      :: SheetId

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]
+          -- Determine old submission users
-          deleteWhere [InvitationFor ==. invRef @SubmissionUser smid, InvitationEmail /<-. subEmails]
+          subUsersOld <- if
-          insertMany_ $ map (flip SubmissionUser smid) subUids
+            | isJust msmid -> setOf (folded . _entityVal . _submissionUserUser . to Right) <$> selectList [SubmissionUserSubmission ==. smid] []
-          sinkInvitationsF submissionUserInvitationConfig $ map (\lEmail -> (lEmail, smid, (InvDBDataSubmissionUser, InvTokenDataSubmissionUser))) subEmails
+            | 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

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

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 --
 ----------

src/Utils/Lens.hs

@@ -169,6 +169,8 @@ makeLenses_ ''File
 
 makeLenses_ ''Submission
 
+makeLenses_ ''SubmissionUser
+
 
 -- makeClassy_ ''Load