fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

feat(submission-groups): invite w/ submission-group & audit

Browse Source
This commit is contained in:
Gregor Kleen 2020-04-28 15:49:20 +02:00
parent 52670bc905
commit 7f10d44aee
6 changed files with 100 additions and 30 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
src/Audit/Types.hs
View File

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

47
src/Handler/Course/ParticipantInvite.hs
View File

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

25
src/Handler/Course/Users.hs
View File

@ -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}|]

42
src/Handler/Utils/Course.hs
View File

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

2
src/Import/NoModel.hs
View File

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

4
src/Utils.hs
View File

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