chore(add-users): remove invite functionality, implement avs form stub
This commit is contained in:
Sarah Vaupel
parent
4a00907bda
commit
ddc71d7fd0
@ -107,8 +107,16 @@ CourseParticipantInvitationAccepted courseName@Text: Sie wurden als Teilnehmer:i
|
||||
CourseParticipantEnlistDirectly: Bekannte Nutzer:innen sofort als Teilnehmer:in eintragen
|
||||
CourseSubmissionGroup: Feste Abgabegruppe
|
||||
SubmissionGroupEmptyIsUnsetTip: Leer lassen um Benutzer:innen aus den jeweiligen Abgabegruppen ersatzlos zu entfernen
|
||||
CourseParticipantsRegisterHeading: Kursteilnehmer :innen hinzufügen
|
||||
CourseParticipantsRegisterHeading: Kursteilnehmer:innen hinzufügen
|
||||
CourseParticipantsRegisterUsersField: Zum Kurs anzumeldende Personen
|
||||
CourseParticipantsRegisterUsersFieldTip: Bitte Personalnummer angeben. Mehrere Personen bitte mit Komma getrennt angeben.
|
||||
CourseParticipantsRegisterTutorialOption: Kursteilnehmer:innen zu Übungsgruppe anmelden?
|
||||
CourseParticipantsRegisterTutorialField: Übungsgruppe
|
||||
CourseParticipantsRegisterTutorialFieldTip: Ist aktuell keine Übungsgruppe mit diesem Namen vorhanden, wird eine neue erstellt. Ist bereits eine Übungsgruppe mit diesem Namen vorhanden, werden die Kursteilnehmenden dieser hinzugefügt.
|
||||
CourseParticipantsRegisterNoneGiven: Es wurden keine anzumeldenden Personen angegeben!
|
||||
|
||||
CourseParticipantsInvited n@Int: #{n} #{pluralDE n "Einladung" "Einladungen"} per E-Mail verschickt
|
||||
CourseParticipantsAddedByAvs n@Int: #{n} AVS-Nutzer erfolgreich angemeldet (TODO)
|
||||
CourseParticipantsAlreadyRegistered n@Int: #{n} #{pluralDE n "Teinehmer:in" "Teilnehmer:innen"} #{pluralDE n "ist" "sind"} bereits angemeldet
|
||||
CourseParticipantsRegistered n@Int: #{n} #{pluralDE n "Teinehmer:in" "Teilnehmer:innen"} erfolgreich angemeldet
|
||||
CourseApplicationText: Text-Bewerbung
|
||||
|
||||
@ -108,7 +108,15 @@ CourseParticipantEnlistDirectly: Enrol known users directly
|
||||
CourseSubmissionGroup: Registered submission group
|
||||
SubmissionGroupEmptyIsUnsetTip: Leave empty to remove users from their respective submission groups
|
||||
CourseParticipantsRegisterHeading: Add course participants
|
||||
CourseParticipantsRegisterUsersField: Persons to register for course
|
||||
CourseParticipantsRegisterUsersFieldTip: Please enter personal number. Please separate multiple entries with commas.
|
||||
CourseParticipantsRegisterTutorialOption: Register course participants for tutorial?
|
||||
CourseParticipantsRegisterTutorialField: Tutorial
|
||||
CourseParticipantsRegisterTutorialFieldTip: If there is no tutorial with this name, a new one will be created. If there is a tutorial with this name, the course participants will be registered for it.
|
||||
CourseParticipantsRegisterNoneGiven: No persons given to register!
|
||||
|
||||
CourseParticipantsInvited n: #{n} #{pluralEN n "invitation" "invitations"} sent via email
|
||||
CourseParticipantsAddedByAvs n: #{n} AVS users successfully registered (TODO)
|
||||
CourseParticipantsAlreadyRegistered n: #{n} #{pluralEN n "participant is" "participants are"} already enrolled
|
||||
CourseParticipantsRegistered n: Successfully registered #{n} #{pluralEN n "participant" "participants"}
|
||||
CourseApplicationText: Application text
|
||||
|
||||
1
routes
1
routes
@ -174,7 +174,6 @@
|
||||
/delete CDeleteR GET POST !lecturerANDemptyANDallocation-time
|
||||
/users CUsersR GET POST
|
||||
!/users/new CAddUserR GET POST !lecturerANDallocation-time
|
||||
!/users/invite CInviteR GET POST
|
||||
/users/#CryptoUUIDUser CUserR GET POST !lecturerANDparticipant !lecturerANDapplicant
|
||||
/correctors CHiWisR GET
|
||||
/communication CCommR GET POST
|
||||
|
||||
@ -249,7 +249,6 @@ breadcrumb (CourseR tid ssh csh CShowR) = useRunDB . maybeT (i18nCrumb MsgBreadc
|
||||
breadcrumb (CourseR tid ssh csh CEditR) = i18nCrumb MsgMenuCourseEdit . Just $ CourseR tid ssh csh CShowR
|
||||
breadcrumb (CourseR tid ssh csh CUsersR) = i18nCrumb MsgMenuCourseMembers . Just $ CourseR tid ssh csh CShowR
|
||||
breadcrumb (CourseR tid ssh csh CAddUserR) = i18nCrumb MsgMenuCourseAddMembers . Just $ CourseR tid ssh csh CUsersR
|
||||
breadcrumb (CourseR tid ssh csh CInviteR) = i18nCrumb MsgBreadcrumbCourseParticipantInvitation . Just $ CourseR tid ssh csh CShowR
|
||||
breadcrumb (CourseR tid ssh csh CExamOfficeR) = i18nCrumb MsgMenuCourseExamOffice . Just $ CourseR tid ssh csh CShowR
|
||||
breadcrumb (CourseR tid ssh csh (CUserR cID)) = useRunDB . maybeT (i18nCrumb MsgBreadcrumbUser . Just $ CourseR tid ssh csh CUsersR) $ do
|
||||
guardM . lift . hasReadAccessTo . CourseR tid ssh csh $ CUserR cID
|
||||
|
||||
@ -2,137 +2,39 @@
|
||||
--
|
||||
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module Handler.Course.ParticipantInvite
|
||||
( InvitableJunction(..), InvitationDBData(..), InvitationTokenData(..)
|
||||
, getCInviteR, postCInviteR
|
||||
, getCAddUserR, postCAddUserR
|
||||
( getCAddUserR, postCAddUserR
|
||||
, AddParticipantsResult(..)
|
||||
, addParticipantsResultMessages
|
||||
, registerUsers, registerUser
|
||||
, registerUsers', registerUser'
|
||||
) where
|
||||
|
||||
import Import
|
||||
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Invitations
|
||||
import Handler.Utils.Course
|
||||
import Handler.Utils.Avs
|
||||
|
||||
import Jobs.Queue
|
||||
|
||||
import Control.Monad.Except (MonadError(..))
|
||||
|
||||
import Data.Aeson hiding (Result(..))
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
import qualified Data.HashSet as HashSet
|
||||
--import Data.Aeson hiding (Result(..))
|
||||
--import qualified Data.CaseInsensitive as CI
|
||||
--import qualified Data.HashSet as HashSet
|
||||
import Data.List (genericLength)
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.Time.Zones as TZ
|
||||
import qualified Data.Set as Set
|
||||
|
||||
import Control.Monad.Except (MonadError(..))
|
||||
import Generics.Deriving.Monoid (memptydefault, mappenddefault)
|
||||
|
||||
|
||||
data CourseAvsRegisterForm = CourseAvsRegisterForm
|
||||
{ cavsregParticipants :: Set Text -- TODO: NonEmpty
|
||||
, cavsregTutorial :: Maybe Day
|
||||
}
|
||||
deriving (Eq, Ord, Show, Read, Generic, Typeable)
|
||||
|
||||
makeLenses_ ''CourseAvsRegisterForm
|
||||
|
||||
-- TODO: merge to postCAddUserR
|
||||
_courseAvsRegisterForm :: Maybe CourseAvsRegisterForm -> AForm Handler CourseAvsRegisterForm
|
||||
_courseAvsRegisterForm template = wFormToAForm $ do
|
||||
today <- localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime
|
||||
|
||||
let
|
||||
cfCommaSeparatedSet :: forall m. Functor m => Field m Text -> Field m (Set Text)
|
||||
cfCommaSeparatedSet = guardField (not . Set.null) . convertField (Set.fromList . mapMaybe (assertM' (not . Text.null) . Text.strip) . Text.splitOn ",") (Text.intercalate ", " . Set.toList)
|
||||
|
||||
aFormToWForm $ CourseAvsRegisterForm
|
||||
<$> areq (textField & cfCommaSeparatedSet) (fslI MsgCourseAvsRegisterParticipants & setTooltip MsgCourseAvsRegisterParticipantsTip) (cavsregParticipants <$> template)
|
||||
<*> optionalActionA
|
||||
( areq dayField (fslI MsgCourseAvsRegisterTutorialDay) (Just . fromMaybe today . join $ cavsregTutorial <$> template)
|
||||
)
|
||||
(fslI MsgCourseAvsRegisterCreateTutorial) ((is _Just . cavsregTutorial <$> template) <|> Just True)
|
||||
|
||||
|
||||
-- Invitations for ordinary participants of this course
|
||||
instance IsInvitableJunction CourseParticipant where
|
||||
type InvitationFor CourseParticipant = Course
|
||||
data InvitableJunction CourseParticipant = JunctionParticipant
|
||||
{ jParticipantRegistration :: UTCTime
|
||||
, jParticipantAllocated :: Maybe AllocationId
|
||||
, jParticipantState :: CourseParticipantState
|
||||
} deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
data InvitationDBData CourseParticipant = InvDBDataParticipant
|
||||
-- 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
|
||||
(\CourseParticipant{..} -> (courseParticipantUser, courseParticipantCourse, JunctionParticipant courseParticipantRegistration courseParticipantAllocated courseParticipantState))
|
||||
(\(courseParticipantUser, courseParticipantCourse, JunctionParticipant courseParticipantRegistration courseParticipantAllocated courseParticipantState) -> CourseParticipant{..})
|
||||
|
||||
instance ToJSON (InvitableJunction CourseParticipant) where
|
||||
toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
|
||||
toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
|
||||
instance FromJSON (InvitableJunction CourseParticipant) where
|
||||
parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
|
||||
|
||||
instance ToJSON (InvitationDBData CourseParticipant) where
|
||||
toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 3 }
|
||||
toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 3 }
|
||||
instance FromJSON (InvitationDBData CourseParticipant) where
|
||||
parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 3 }
|
||||
|
||||
instance ToJSON (InvitationTokenData CourseParticipant) where
|
||||
toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 3, omitNothingFields = True }
|
||||
toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 3, omitNothingFields = True }
|
||||
instance FromJSON (InvitationTokenData CourseParticipant) where
|
||||
parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 3, omitNothingFields = True }
|
||||
|
||||
participantInvitationConfig :: InvitationConfig CourseParticipant
|
||||
participantInvitationConfig = InvitationConfig{..}
|
||||
where
|
||||
invitationRoute (Entity _ Course{..}) _ = return $ CourseR courseTerm courseSchool courseShorthand CInviteR
|
||||
invitationResolveFor _ = do
|
||||
cRoute <- getCurrentRoute
|
||||
case cRoute of
|
||||
Just (CourseR tid csh ssh CInviteR) ->
|
||||
getKeyBy404 $ TermSchoolCourseShort tid csh ssh
|
||||
_other ->
|
||||
error "participantInvitationConfig called from unsupported route"
|
||||
invitationSubject (Entity _ Course{..}) _ = return . SomeMessage $ MsgMailSubjectParticipantInvitation courseTerm courseSchool courseShorthand
|
||||
invitationHeading (Entity _ Course{..}) _ = return . SomeMessage $ MsgCourseParticipantInviteHeading $ CI.original courseName
|
||||
invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgCourseParticipantInviteExplanation}|]
|
||||
invitationTokenConfig _ _ = do
|
||||
itAuthority <- HashSet.singleton . Right <$> liftHandler requireAuthId
|
||||
return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
|
||||
invitationRestriction _ _ = return Authorized
|
||||
invitationForm _ _ _ = hoistAForm lift . wFormToAForm $ do
|
||||
now <- liftIO getCurrentTime
|
||||
return . pure . (, ()) $ JunctionParticipant now Nothing CourseParticipantActive
|
||||
invitationInsertHook _ (Entity _ Course{..}) (_, InvTokenDataParticipant{..}) CourseParticipant{..} _ act = do
|
||||
deleteBy $ UniqueParticipant courseParticipantUser courseParticipantCourse -- there are no foreign key references to @{CourseParticipant}; therefor we can delete and recreate to simulate upsert
|
||||
res <- act -- insertUnique
|
||||
audit $ TransactionCourseParticipantEdit courseParticipantCourse courseParticipantUser
|
||||
void $ setUserSubmissionGroup courseParticipantCourse courseParticipantUser invTokenParticipantSubmissionGroup
|
||||
memcachedByInvalidate (AuthCacheCourseRegisteredList courseTerm courseSchool courseShorthand) (Proxy @(Set UserId))
|
||||
return res
|
||||
invitationSuccessMsg (Entity _ Course{..}) _ =
|
||||
return . SomeMessage $ MsgCourseParticipantInvitationAccepted (CI.original courseName)
|
||||
invitationUltDest (Entity _ Course{..}) _ = return . SomeRoute $ CourseR courseTerm courseSchool courseShorthand CShowR
|
||||
|
||||
data AddParticipantsResult = AddParticipantsResult
|
||||
{ aurAlreadyRegistered
|
||||
, aurSuccess :: Set UserId
|
||||
, aurAlreadyTutorialMember
|
||||
, aurRegisterSuccess
|
||||
, aurTutorialSuccess :: Set UserId
|
||||
} deriving (Read, Show, Generic, Typeable)
|
||||
|
||||
instance Semigroup AddParticipantsResult where
|
||||
@ -142,50 +44,53 @@ instance Monoid AddParticipantsResult where
|
||||
mempty = memptydefault
|
||||
mappend = (<>)
|
||||
|
||||
|
||||
getCAddUserR, postCAddUserR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||
getCAddUserR = postCAddUserR
|
||||
postCAddUserR tid ssh csh = do
|
||||
cid <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
cid <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
-- mr <- getMessageRender
|
||||
today <- localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime
|
||||
|
||||
((usersToEnlist,formWgt),formEncoding) <- runFormPost . renderWForm FormStandard $ do
|
||||
enlist <- wreq checkBoxField (fslI MsgCourseParticipantEnlistDirectly) (Just False)
|
||||
let
|
||||
cfCommaSeparatedSet :: forall m. Functor m => Field m Text -> Field m (Set Text)
|
||||
cfCommaSeparatedSet = guardField (not . Set.null) . convertField (Set.fromList . mapMaybe (assertM' (not . Text.null) . Text.strip) . Text.splitOn ",") (Text.intercalate ", " . Set.toList)
|
||||
|
||||
let submissionGroupOpts = optionsPersist [SubmissionGroupCourse ==. cid] [Asc SubmissionGroupName] submissionGroupName <&> fmap (submissionGroupName . entityVal)
|
||||
mbGrp <- wopt (textField & cfStrip & cfCI & addDatalist submissionGroupOpts) (fslI MsgCourseSubmissionGroup & setTooltip MsgSubmissionGroupEmptyIsUnsetTip) Nothing
|
||||
((usersToRegister, formWgt), formEncoding) <- runFormPost . renderWForm FormStandard $ do
|
||||
users <- wreq (textField & cfCommaSeparatedSet) (fslI MsgCourseParticipantsRegisterUsersField & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) mempty
|
||||
mTutorial <- optionalActionW
|
||||
( areq textField (fslI MsgCourseParticipantsRegisterTutorialField & setTooltip MsgCourseParticipantsRegisterTutorialFieldTip) (Just $ tshow today) ) -- TODO: use user date display setting
|
||||
( fslI MsgCourseParticipantsRegisterTutorialOption )
|
||||
( Just True )
|
||||
return $ Map.fromSet . const <$> mTutorial <*> users
|
||||
|
||||
mr <- getMessageRender
|
||||
users <- wreq (multiUserInvitationField . maybe MUIAlwaysInvite (const $ MUILookupAnyUser Nothing) $ formResultToMaybe enlist)
|
||||
(fslpI MsgCourseParticipantInviteField (mr MsgLdapIdentificationOrEmail) & setTooltip MsgMultiEmailFieldTip) Nothing
|
||||
formResultModal usersToRegister (CourseR tid ssh csh CUsersR) $
|
||||
registerUsers cid -- TODO: register for tutorial, if specified
|
||||
|
||||
return $ Map.fromSet . const <$> mbGrp <*> users
|
||||
let heading = prependCourseTitle tid ssh csh MsgCourseParticipantsRegisterHeading
|
||||
|
||||
formResultModal usersToEnlist (CourseR tid ssh csh CUsersR) $
|
||||
hoist runDBJobs . registerUsers' cid
|
||||
|
||||
let heading = prependCourseTitle tid ssh csh MsgCourseParticipantsRegisterHeading
|
||||
|
||||
siteLayoutMsg heading $ do
|
||||
setTitleI heading
|
||||
wrapForm formWgt def
|
||||
{ formEncoding
|
||||
, formAction = Just . SomeRoute $ CourseR tid ssh csh CAddUserR
|
||||
}
|
||||
siteLayoutMsg heading $ do
|
||||
setTitleI heading
|
||||
wrapForm formWgt def
|
||||
{ formEncoding
|
||||
, formAction = Just . SomeRoute $ CourseR tid ssh csh CAddUserR
|
||||
}
|
||||
|
||||
|
||||
registerUsers :: CourseId -> Set (Either UserEmail UserId) -> WriterT [Message] (YesodJobDB UniWorX) ()
|
||||
registerUsers cid = registerUsers' cid . Map.fromSet (const Nothing)
|
||||
registerUsers :: CourseId -> Map Text (Maybe Text) -> WriterT [Message] Handler ()
|
||||
registerUsers cid usersToRegister = do
|
||||
avsUsers :: Map Text (Maybe UserId) <- fmap Map.fromList . forM (Map.keys usersToRegister) $ \userIdent -> do
|
||||
mUser <- liftHandler $ upsertAvsUser userIdent -- TODO: upsertAvsUser should return whole Entity
|
||||
return (userIdent, mUser)
|
||||
|
||||
registerUsers' :: CourseId -> Map (Either UserEmail UserId) (Maybe SubmissionGroupName) -> WriterT [Message] (YesodJobDB UniWorX) ()
|
||||
registerUsers' cid users = do
|
||||
let (emails,uids) = partitionKeysEither users
|
||||
when (null avsUsers) $
|
||||
tell . pure =<< messageI Error MsgCourseParticipantsRegisterNoneGiven
|
||||
|
||||
-- send Invitation eMails to unkown users
|
||||
lift $ sinkInvitationsF participantInvitationConfig [(mail,cid,(InvDBDataParticipant,InvTokenDataParticipant{..})) | (mail, invTokenParticipantSubmissionGroup) <- Map.toList emails]
|
||||
-- register known users
|
||||
tell <=< lift . addParticipantsResultMessages <=< lift . execWriterT $ imapM_ (registerUser' cid) uids
|
||||
-- tell <=< lift . addParticipantsResultMessages <=< lift . execWriterT $ imapM_ (registerUser cid) uids
|
||||
|
||||
unless (null emails) $
|
||||
tell . pure <=< messageI Success . MsgCourseParticipantsInvited $ length emails
|
||||
-- unless (null avsUsers) $
|
||||
-- tell . pure <=< messageI Success . MsgCourseParticipantsAddedByAvs $ length avsUsers
|
||||
|
||||
|
||||
addParticipantsResultMessages :: (MonadHandler m, HandlerSite m ~ UniWorX)
|
||||
@ -199,21 +104,18 @@ addParticipantsResultMessages AddParticipantsResult{..} = execWriterT $ do
|
||||
let modalTrigger = [whamlet|_{MsgCourseParticipantsAlreadyRegistered (length aurAlreadyRegistered)}|]
|
||||
modalContent = $(widgetFile "messages/courseInvitationAlreadyRegistered")
|
||||
tell . pure <=< messageWidget Info $ msgModal modalTrigger (Right modalContent)
|
||||
-- TODO: aurAlreadyTutorialMember
|
||||
|
||||
unless (null aurSuccess) $
|
||||
tell . pure <=< messageI Success . MsgCourseParticipantsRegistered $ length aurSuccess
|
||||
unless (null aurRegisterSuccess) $
|
||||
tell . pure <=< messageI Success . MsgCourseParticipantsRegistered $ length aurRegisterSuccess
|
||||
unless (null aurTutorialSuccess) $
|
||||
tell . pure <=< messageI Success . MsgCourseUsersTutorialRegistered . genericLength $ Set.toList aurTutorialSuccess
|
||||
|
||||
|
||||
registerUser :: CourseId
|
||||
-> UserId
|
||||
-> WriterT AddParticipantsResult (YesodJobDB UniWorX) ()
|
||||
registerUser cid uid = registerUser' cid uid Nothing
|
||||
|
||||
registerUser' :: CourseId
|
||||
-> UserId
|
||||
-> Maybe SubmissionGroupName
|
||||
-> WriterT AddParticipantsResult (YesodJobDB UniWorX) ()
|
||||
registerUser' cid uid mbGrp = exceptT tell tell $ do
|
||||
registerUser cid uid = exceptT tell tell $ do
|
||||
whenM (lift . lift $ exists [CourseParticipantCourse ==. cid, CourseParticipantUser ==. uid, CourseParticipantState ==. CourseParticipantActive]) $
|
||||
throwError $ mempty { aurAlreadyRegistered = Set.singleton uid }
|
||||
|
||||
@ -233,11 +135,4 @@ registerUser' cid uid mbGrp = 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 $ mempty { aurSuccess = Set.singleton uid }
|
||||
|
||||
|
||||
getCInviteR, postCInviteR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||
getCInviteR = postCInviteR
|
||||
postCInviteR = invitationR participantInvitationConfig
|
||||
return $ mempty { aurRegisterSuccess = Set.singleton uid }
|
||||
|
||||
Loading…
Reference in New Issue
Block a user