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

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

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 }
+  toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 3, omitNothingFields = True }
-  toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
+  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
+registerUsers cid = registerUsers' cid . Map.fromSet (const Nothing)
-  let (emails,uids) = partitionEithers $ Set.toList users
+
+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 }

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
+    (CourseUserSetSubmissionGroupData{..}, selectedUsers) -> do
-      Sum nrSet <- runDB $ do
+      nrSet <- runDB $ setUsersSubmissionGroup cid selectedUsers setSubmissionGroup
-        Entity gId _ <- upsert (SubmissionGroup cid setSubmissionGroup) [ SubmissionGroupName =. setSubmissionGroup ]
+
-        flip foldMapM selectedUsers $ \uid ->
+      case setSubmissionGroup of
-          fmap (maybe mempty . const $ Sum 1) . insertUnique $ SubmissionGroupUser gId uid 
+        Nothing -> addMessageI Success $ MsgCourseUsersSubmissionGroupUnset  nrSet
-      addMessageI Success $ MsgCourseUsersSubmissionGroupSetNew nrSet
+        Just _  -> 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
       redirect $ CourseR tid ssh csh CUsersR
 
   let headingLong  = [whamlet|_{MsgMenuCourseMembers} #{courseName course} #{tid}|]

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

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
 

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