From 7f10d44aee0fea561e331e20d03ff814a6df9baa Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 28 Apr 2020 15:49:20 +0200 Subject: [PATCH] feat(submission-groups): invite w/ submission-group & audit --- src/Audit/Types.hs | 10 ++++++ src/Handler/Course/ParticipantInvite.hs | 47 ++++++++++++++++++------- src/Handler/Course/Users.hs | 25 +++++-------- src/Handler/Utils/Course.hs | 42 ++++++++++++++++++++++ src/Import/NoModel.hs | 2 +- src/Utils.hs | 4 +++ 6 files changed, 100 insertions(+), 30 deletions(-) diff --git a/src/Audit/Types.hs b/src/Audit/Types.hs index 88add95c9..61c3628a9 100644 --- a/src/Audit/Types.hs +++ b/src/Audit/Types.hs @@ -178,6 +178,16 @@ data Transaction , transactionUser :: UserId } + | TransactionSubmissionGroupSet + { transactionCourse :: CourseId + , transactionUser :: UserId + , transactionSubmissionGroup :: SubmissionGroupName + } + | TransactionSubmissionGroupUnset + { transactionCourse :: CourseId + , transactionUser :: UserId + } + deriving (Eq, Ord, Read, Show, Generic, Typeable) deriveJSON defaultOptions diff --git a/src/Handler/Course/ParticipantInvite.hs b/src/Handler/Course/ParticipantInvite.hs index c3d677382..4cd3a3538 100644 --- a/src/Handler/Course/ParticipantInvite.hs +++ b/src/Handler/Course/ParticipantInvite.hs @@ -7,6 +7,7 @@ module Handler.Course.ParticipantInvite , AddParticipantsResult(..) , addParticipantsResultMessages , registerUsers, registerUser + , registerUsers', registerUser' ) where import Import @@ -14,10 +15,12 @@ import Import import Utils.Form import Handler.Utils import Handler.Utils.Invitations +import Handler.Utils.Course import qualified Data.CaseInsensitive as CI import qualified Data.Set as Set +import qualified Data.Map as Map import Jobs.Queue @@ -44,6 +47,8 @@ instance IsInvitableJunction CourseParticipant where -- no data needed in DB to manage participant invitation deriving (Eq, Ord, Read, Show, Generic, Typeable) data InvitationTokenData CourseParticipant = InvTokenDataParticipant + { invTokenParticipantSubmissionGroup :: Maybe SubmissionGroupName + } deriving (Eq, Ord, Read, Show, Generic, Typeable) _InvitableJunction = iso @@ -63,10 +68,10 @@ instance FromJSON (InvitationDBData CourseParticipant) where parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 3 } instance ToJSON (InvitationTokenData CourseParticipant) where - toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 } - toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelToPathPiece' 3 } + toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 3, omitNothingFields = True } + toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 3, omitNothingFields = True } instance FromJSON (InvitationTokenData CourseParticipant) where - parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 } + parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 3, omitNothingFields = True } participantInvitationConfig :: InvitationConfig CourseParticipant participantInvitationConfig = InvitationConfig{..} @@ -91,9 +96,10 @@ participantInvitationConfig = InvitationConfig{..} studyFeatures <- wreq (studyFeaturesFieldFor Nothing False [] $ Just uid) (fslI MsgCourseStudyFeature & setTooltip MsgCourseStudyFeatureTip) Nothing return . fmap (, ()) $ JunctionParticipant <$> pure now <*> studyFeatures <*> pure Nothing - invitationInsertHook _ _ _ CourseParticipant{..} _ act = do + invitationInsertHook _ _ (_, InvTokenDataParticipant{..}) CourseParticipant{..} _ act = do res <- act audit $ TransactionCourseParticipantEdit courseParticipantCourse courseParticipantUser + void $ setUserSubmissionGroup courseParticipantCourse courseParticipantUser invTokenParticipantSubmissionGroup return res invitationSuccessMsg (Entity _ Course{..}) _ = return . SomeMessage $ MsgCourseParticipantInvitationAccepted (CI.original courseName) @@ -118,11 +124,17 @@ postCAddUserR tid ssh csh = do cid <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh ((usersToEnlist,formWgt),formEncoding) <- runFormPost . renderWForm FormStandard $ do enlist <- wreq checkBoxField (fslI MsgCourseParticipantEnlistDirectly) (Just False) - wreq (multiUserField (maybe True not $ formResultToMaybe enlist) Nothing) - (fslI MsgCourseParticipantInviteField & setTooltip MsgMultiEmailFieldTip) Nothing + + let submissionGroupOpts = optionsPersist [SubmissionGroupCourse ==. cid] [Asc SubmissionGroupName] submissionGroupName <&> fmap (submissionGroupName . entityVal) + mbGrp <- wopt (textField & cfStrip & cfCI & addDatalist submissionGroupOpts) (fslI MsgSubmissionGroup & setTooltip MsgSubmissionGroupEmptyIsUnsetTip) Nothing + + users <- wreq (multiUserField (maybe True not $ formResultToMaybe enlist) Nothing) + (fslI MsgCourseParticipantInviteField & setTooltip MsgMultiEmailFieldTip) Nothing + + return $ Map.fromSet . const <$> mbGrp <*> users formResultModal usersToEnlist (CourseR tid ssh csh CUsersR) $ - hoist runDBJobs . registerUsers cid + hoist runDBJobs . registerUsers' cid let heading = prependCourseTitle tid ssh csh MsgCourseParticipantsRegisterHeading @@ -135,13 +147,16 @@ postCAddUserR tid ssh csh = do } registerUsers :: CourseId -> Set (Either UserEmail UserId) -> WriterT [Message] (YesodJobDB UniWorX) () -registerUsers cid users = do - let (emails,uids) = partitionEithers $ Set.toList users +registerUsers cid = registerUsers' cid . Map.fromSet (const Nothing) + +registerUsers' :: CourseId -> Map (Either UserEmail UserId) (Maybe SubmissionGroupName) -> WriterT [Message] (YesodJobDB UniWorX) () +registerUsers' cid users = do + let (emails,uids) = partitionKeysEither users -- send Invitation eMails to unkown users - lift $ sinkInvitationsF participantInvitationConfig [(mail,cid,(InvDBDataParticipant,InvTokenDataParticipant)) | mail <- emails] + lift $ sinkInvitationsF participantInvitationConfig [(mail,cid,(InvDBDataParticipant,InvTokenDataParticipant{..})) | (mail, invTokenParticipantSubmissionGroup) <- Map.toList emails] -- register known users - tell <=< lift . addParticipantsResultMessages <=< lift . execWriterT $ mapM_ (registerUser cid) uids + tell <=< lift . addParticipantsResultMessages <=< lift . execWriterT $ imapM_ (registerUser' cid) uids unless (null emails) $ tell . pure <=< messageI Success . MsgCourseParticipantsInvited $ length emails @@ -172,7 +187,13 @@ addParticipantsResultMessages AddParticipantsResult{..} = execWriterT $ do registerUser :: CourseId -> UserId -> WriterT AddParticipantsResult (YesodJobDB UniWorX) () -registerUser cid uid = exceptT tell tell $ do +registerUser cid uid = registerUser' cid uid Nothing + +registerUser' :: CourseId + -> UserId + -> Maybe SubmissionGroupName + -> WriterT AddParticipantsResult (YesodJobDB UniWorX) () +registerUser' cid uid mbGrp = exceptT tell tell $ do whenM (lift . lift . existsBy $ UniqueParticipant uid cid) $ throwError $ mempty { aurAlreadyRegistered = Set.singleton uid } @@ -198,6 +219,8 @@ registerUser cid uid = exceptT tell tell $ do lift . lift . audit $ TransactionCourseParticipantEdit cid uid lift . lift . queueDBJob . JobQueueNotification $ NotificationCourseRegistered uid cid + void . lift . lift $ setUserSubmissionGroup cid uid mbGrp + return $ case courseParticipantField of Nothing -> mempty { aurNoUniquePrimaryField = Set.singleton uid } Just _ -> mempty { aurSuccess = Set.singleton uid } diff --git a/src/Handler/Course/Users.hs b/src/Handler/Course/Users.hs index e6e4779b3..c2ab01c15 100644 --- a/src/Handler/Course/Users.hs +++ b/src/Handler/Course/Users.hs @@ -11,6 +11,7 @@ import Import import Utils.Form import Handler.Utils +import Handler.Utils.Course import qualified Database.Esqueleto.Utils as E import Database.Esqueleto.Utils.TH @@ -629,23 +630,13 @@ postCUsersR tid ssh csh = do return mempty addMessageI Success $ MsgCourseUsersExamRegistered nrReg redirect $ CourseR tid ssh csh CUsersR - (CourseUserSetSubmissionGroupData{ setSubmissionGroup = Just setSubmissionGroup }, selectedUsers) -> do - Sum nrSet <- runDB $ do - Entity gId _ <- upsert (SubmissionGroup cid setSubmissionGroup) [ SubmissionGroupName =. setSubmissionGroup ] - flip foldMapM selectedUsers $ \uid -> - fmap (maybe mempty . const $ Sum 1) . insertUnique $ SubmissionGroupUser gId uid - addMessageI Success $ MsgCourseUsersSubmissionGroupSetNew nrSet - redirect $ CourseR tid ssh csh CUsersR - (CourseUserSetSubmissionGroupData{ setSubmissionGroup = Nothing }, selectedUsers) -> do - nrUnset <- runDB $ do - nrUnset <- E.deleteCount . E.from $ \submissionGroupUser -> - E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser `E.in_` E.valList (Set.toList selectedUsers) - E.&&. E.subSelectForeign submissionGroupUser SubmissionGroupUserSubmissionGroup (E.^. SubmissionGroupCourse) E.==. E.val cid - E.delete . E.from $ \submissionGroup -> - E.where_ $ submissionGroup E.^. SubmissionGroupCourse E.==. E.val cid - E.&&. E.not_ (E.exists . E.from $ \submissionGroupUser -> E.where_ $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId) - return nrUnset - addMessageI Success $ MsgCourseUsersSubmissionGroupUnset nrUnset + (CourseUserSetSubmissionGroupData{..}, selectedUsers) -> do + nrSet <- runDB $ setUsersSubmissionGroup cid selectedUsers setSubmissionGroup + + case setSubmissionGroup of + Nothing -> addMessageI Success $ MsgCourseUsersSubmissionGroupUnset nrSet + Just _ -> addMessageI Success $ MsgCourseUsersSubmissionGroupSetNew nrSet + redirect $ CourseR tid ssh csh CUsersR let headingLong = [whamlet|_{MsgMenuCourseMembers} #{courseName course} #{tid}|] diff --git a/src/Handler/Utils/Course.hs b/src/Handler/Utils/Course.hs index cb16f7d20..699f96aa5 100644 --- a/src/Handler/Utils/Course.hs +++ b/src/Handler/Utils/Course.hs @@ -4,6 +4,8 @@ import Import import Handler.Utils.Delete import qualified Database.Esqueleto as E + +import qualified Data.Set as Set courseDeleteRoute :: Set CourseId -> DeleteRoute Course @@ -27,3 +29,43 @@ courseDeleteRoute drRecords = DeleteRoute , drSuccess = error "drSuccess undefined" , drDelete = const id -- TODO: audit } + +setUserSubmissionGroup :: ( MonadHandler m + , HandlerSite m ~ UniWorX + , backend ~ SqlBackend + , MonadCatch m + ) => CourseId -> UserId -> Maybe SubmissionGroupName -> ReaderT backend m Bool +setUserSubmissionGroup cid uid = fmap (> 0) . setUsersSubmissionGroup cid (Set.singleton uid) + +setUsersSubmissionGroup :: ( MonadHandler m + , HandlerSite m ~ UniWorX + , backend ~ SqlBackend + , MonadCatch m + ) => CourseId -> Set UserId -> Maybe SubmissionGroupName -> ReaderT backend m Int64 +setUsersSubmissionGroup cid uids Nothing = do + didDelete <- fmap getSum . flip foldMapM uids $ \uid -> do + didDelete <- fmap (> 0) . E.deleteCount . E.from $ \submissionGroupUser -> + E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. E.val uid + E.&&. E.subSelectForeign submissionGroupUser SubmissionGroupUserSubmissionGroup (E.^. SubmissionGroupCourse) E.==. E.val cid + when didDelete $ + audit $ TransactionSubmissionGroupUnset cid uid + return $ bool mempty (Sum 1) didDelete + E.delete . E.from $ \submissionGroup -> + E.where_ $ submissionGroup E.^. SubmissionGroupCourse E.==. E.val cid + E.&&. E.not_ (E.exists . E.from $ \submissionGroupUser -> E.where_ $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId) + return didDelete +setUsersSubmissionGroup cid uids (Just grp) = do + Entity gId _ <- upsert (SubmissionGroup cid grp) [ SubmissionGroupName =. grp ] + + E.delete . E.from $ \submissionGroupUser -> + E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser `E.in_` E.valList (Set.toList uids) + E.&&. E.subSelectForeign submissionGroupUser SubmissionGroupUserSubmissionGroup (E.^. SubmissionGroupCourse) E.==. E.val cid + E.&&. submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup E.!=. E.val gId + E.delete . E.from $ \submissionGroup -> + E.where_ $ submissionGroup E.^. SubmissionGroupCourse E.==. E.val cid + E.&&. E.not_ (E.exists . E.from $ \submissionGroupUser -> E.where_ $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId) + fmap getSum . flip foldMapM uids $ \uid -> do + didSet <- fmap (is _Just) . insertUnique $ SubmissionGroupUser gId uid + when didSet $ + audit $ TransactionSubmissionGroupSet cid uid grp + return $ bool mempty (Sum 1) didSet diff --git a/src/Import/NoModel.hs b/src/Import/NoModel.hs index 3a5365c57..e4b0dd6b5 100644 --- a/src/Import/NoModel.hs +++ b/src/Import/NoModel.hs @@ -70,7 +70,7 @@ import Data.Ratio as Import ((%)) import Net.IP as Import (IP) -import Database.Persist.Sql as Import (SqlReadT, SqlWriteT, fromSqlKey, toSqlKey) +import Database.Persist.Sql as Import (SqlReadT, SqlWriteT, IsSqlBackend, fromSqlKey, toSqlKey) import Ldap.Client.Pool as Import diff --git a/src/Utils.hs b/src/Utils.hs index e9d75dd61..a9d9d9f87 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -47,6 +47,7 @@ import qualified Data.Conduit.List as C import Control.Lens import Control.Lens as Utils (none) +import Control.Lens.Extras (is) import Data.Set.Lens import Control.Arrow as Utils ((>>>)) @@ -481,6 +482,9 @@ assocsSet = setOf folded . imap (,) mapF :: (Ord k, Finite k) => (k -> v) -> Map k v mapF = flip Map.fromSet $ Set.fromList universeF +partitionKeysEither :: Map (Either k1 k2) v -> (Map k1 v, Map k2 v) +partitionKeysEither = over _2 (Map.mapKeysMonotonic . view $ singular _Right) . over _1 (Map.mapKeysMonotonic . view $ singular _Left) . Map.partitionWithKey (\k _ -> is _Left k) + --------------- -- Functions -- ---------------