Merge branch 'feat/course-participant-invitation'

messages/uniworx/de.msg

@@ -587,6 +587,8 @@ CommCourseSubject: Kursmitteilung
 MailSubjectLecturerInvitation tid@TermId ssh@SchoolId csh@CourseShorthand: [#{display tid}-#{display ssh}-#{csh}] Einladung zum Kursverwalter
 InvitationAcceptDecline: Einladung annehmen/ablehnen
 
+MailSubjectParticipantInvitation tid@TermId ssh@SchoolId csh@CourseShorthand: [#{display tid}-#{display ssh}-#{csh}] Einladung zum Kursteilname
+
 MailSubjectCorrectorInvitation tid@TermId ssh@SchoolId csh@CourseShorthand shn@SheetName: [#{display tid}-#{display ssh}-#{csh}] Einladung zum Korrektor für #{shn}
 
 MailSubjectTutorInvitation tid@TermId ssh@SchoolId csh@CourseShorthand tutn@TutorialName: [#{display tid}-#{display ssh}-#{csh}] Einladung zum Tutor für #{tutn}
@@ -750,6 +752,7 @@ MenuLogin: Login
 MenuLogout: Logout
 MenuCourseList: Kurse
 MenuCourseMembers: Kursteilnehmer
+MenuCourseAddMembers: Kursteilnehmer hinzufügen
 MenuCourseCommunication: Kursmitteilung
 MenuTermShow: Semester
 MenuSubmissionDelete: Abgabe löschen
@@ -861,6 +864,14 @@ LecturerInvitationDeclined csh@CourseShorthand: Sie haben die Einladung, Kursver
 CourseLecInviteHeading courseName@Text: Einladung zum Kursverwalter für #{courseName}
 CourseLecInviteExplanation: Sie wurden eingeladen, Verwalter für einen Kurs zu sein.
 
+CourseParticipantInviteHeading courseName@Text: Einladung zum Kursteilnahmer für #{courseName}
+CourseParticipantInviteExplanation: Sie wurden eingeladen, an einem Kurs teilzunehmen.
+CourseParticipantEnlistDirectly: bekannte Teilnehmer sofort als Teilnehmer eintragen
+CourseParticipantInviteField: einzuladende EMail Adressen
+
+CourseParticipantInvitationAccepted courseName@Text: Sie wurden als Teilnehmer für #{courseName} eingetragen
+
+
 CorrectorInvitationAccepted shn@SheetName: Sie wurden als Korrektor für #{shn} eingetragen
 CorrectorInvitationDeclined shn@SheetName: Sie haben die Einladung, Korrektor für #{shn} zu werden, abgelehnt
 SheetCorrInviteHeading shn@SheetName: Einladung zum Korrektor für #{shn}
@@ -956,3 +967,9 @@ HealthHTTPReachable: Cluster kann an der erwarteten URL über HTTP erreicht werd
 HealthLDAPAdmins: Anteil der Administratoren, die im LDAP-Verzeichnis gefunden werden können
 HealthSMTPConnect: SMTP-Server kann erreicht werden
 HealthWidgetMemcached: Memcached-Server liefert Widgets korrekt aus
+
+CourseParticipantsInvited n@Int: #{tshow n} #{pluralDE n "Einladung" "Einladungen"} per E-Mail verschickt
+CourseParticipantsAlreadyRegistered n@Int: #{tshow n} Teilnehmer #{pluralDE n "ist" "sind"} bereits angemeldet
+CourseParticipantsRegisteredWithoutField n@Int: #{tshow n} Teilnehmer #{pluralDE n "wurde ohne assoziiertes Hauptfach" "wurden assoziierte Hauptfächer"} angemeldet, da #{pluralDE n "kein eindeutiges Hauptfach bestimmt werden konnte" "keine eindeutigen Hauptfächer bestimmt werden konnten"}
+CourseParticipantsRegistered n@Int: #{tshow n} Teilnehmer erfolgreich angemeldet
+CourseParticipantsRegisterHeading: Kursteilnehmer hinzufügen

routes

@@ -85,6 +85,8 @@
   /lecturer-invite            CLecInviteR      GET POST
   /delete                     CDeleteR         GET POST        !lecturerANDempty
   /users                      CUsersR          GET POST
+  !/users/new                 CAddUserR        GET POST
+  !/users/invite              CInviteR         GET POST
   /users/#CryptoUUIDUser      CUserR           GET POST        !lecturerANDparticipant
   /correctors                 CHiWisR          GET
   /communication              CCommR           GET POST

src/Foundation.hs

@@ -1271,7 +1271,7 @@ siteLayout' headingOverride widget = do
         applySystemMessages
         authTagPivots <- fromMaybe Set.empty <$> takeSessionJson SessionInactiveAuthTags
         forM_ authTagPivots $
-          \authTag -> addMessageWidget Info $ modal [whamlet|_{MsgUnauthorizedDisabledTag authTag}|] (Left $ SomeRoute (AuthPredsR, catMaybes [(toPathPiece GetReferer, ) . toPathPiece <$> mcurrentRoute]))
+          \authTag -> addMessageWidget Info $ msgModal [whamlet|_{MsgUnauthorizedDisabledTag authTag}|] (Left $ SomeRoute (AuthPredsR, catMaybes [(toPathPiece GetReferer, ) . toPathPiece <$> mcurrentRoute]))
         getMessages
 
   let highlight :: Route UniWorX -> Bool -- highlight last route in breadcrumbs, favorites taking priority
@@ -1444,6 +1444,8 @@ instance YesodBreadcrumbs UniWorX where
   --         (CourseR tid ssh csh CRegisterR) -- is POST only
   breadcrumb (CourseR tid ssh csh CEditR)     = return ("Editieren"  , Just $ CourseR tid ssh csh CShowR)
   breadcrumb (CourseR tid ssh csh CUsersR)    = return ("Anmeldungen", Just $ CourseR tid ssh csh CShowR)
+  breadcrumb (CourseR tid ssh csh CAddUserR)  = return ("Kursteilnehmer hinzufügen", Just $ CourseR tid ssh csh CUsersR)
+  breadcrumb (CourseR tid ssh csh CInviteR)   = return ("Einladung", Just $ CourseR tid ssh csh CShowR)
   breadcrumb (CourseR tid ssh csh (CUserR _)) = return ("Teilnehmer" , Just $ CourseR tid ssh csh CUsersR)
   breadcrumb (CourseR tid ssh csh CCorrectionsR) = return ("Abgaben" , Just $ CourseR tid ssh csh CShowR)
   breadcrumb (CourseR tid ssh csh SheetListR) = return ("Übungen"    , Just $ CourseR tid ssh csh CShowR)
@@ -1983,6 +1985,16 @@ pageActions (CourseR tid ssh csh SheetListR) =
       , menuItemAccessCallback' = return True
       }
   ]
+pageActions (CourseR tid ssh csh CUsersR) =
+  [ MenuItem
+      { menuItemType  = PageActionPrime
+      , menuItemLabel = MsgMenuCourseAddMembers
+      , menuItemIcon  = Nothing
+      , menuItemRoute = SomeRoute $ CourseR tid ssh csh CAddUserR
+      , menuItemModal = True
+      , menuItemAccessCallback' = return True
+      }
+  ]
 pageActions (CourseR tid ssh csh MaterialListR) =
   [ MenuItem
       { menuItemType  = PageActionPrime

src/Handler/Course.hs

@@ -41,6 +41,11 @@ import Data.Aeson hiding (Result(..))
 
 import Text.Hamlet (ihamlet)
 
+import Control.Monad.Trans.Writer (WriterT, execWriterT)
+import Control.Monad.Except (MonadError(..))
+
+import Generics.Deriving.Monoid (memptydefault, mappenddefault)
+
 
 -- NOTE: Outdated way to use dbTable; see ProfileDataR Handler for a more recent method.
 type CourseTableData = DBRow (Entity Course, Int, Bool, Entity School)
@@ -710,7 +715,7 @@ lecturerInvitationConfig = InvitationConfig{..}
       itAuthority <- liftHandlerT requireAuthId
       return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
     invitationRestriction _ _ = return Authorized
-    invitationForm _ (InvDBDataLecturer mlType, _) = hoistAForm liftHandlerT $ toJunction <$> case mlType of
+    invitationForm _ (InvDBDataLecturer mlType, _) _ = hoistAForm liftHandlerT $ toJunction <$> case mlType of
       Nothing    -> areq    (selectField optionsFinite) lFs Nothing
       Just lType -> aforced (selectField optionsFinite) lFs lType
       where
@@ -1422,3 +1427,151 @@ postCCommR tid ssh csh = do
 getCLecInviteR, postCLecInviteR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
 getCLecInviteR = postCLecInviteR
 postCLecInviteR = invitationR lecturerInvitationConfig
+
+
+
+-- Invitations for ordinary participants of this course
+instance IsInvitableJunction CourseParticipant where
+  type InvitationFor CourseParticipant = Course
+  data InvitableJunction CourseParticipant = JunctionParticipant
+    { jParticipantRegistration :: UTCTime
+    , jParticipantFild         :: Maybe StudyFeaturesId
+    } 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
+    deriving (Eq, Ord, Read, Show, Generic, Typeable)
+
+  _InvitableJunction = iso
+    (\CourseParticipant{..} -> (courseParticipantUser, courseParticipantCourse, JunctionParticipant courseParticipantRegistration courseParticipantField))
+    (\(courseParticipantUser, courseParticipantCourse, JunctionParticipant courseParticipantRegistration courseParticipantField) -> CourseParticipant{..})
+
+  ephemeralInvitation = Just (iso (const InvDBDataParticipant) (const ()))
+
+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 { constructorTagModifier = camelToPathPiece' 3 }
+  toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 3 }
+instance FromJSON (InvitationTokenData CourseParticipant) where
+  parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
+
+participantInvitationConfig :: InvitationConfig CourseParticipant
+participantInvitationConfig = InvitationConfig{..}
+  where
+    invitationRoute (Entity _ Course{..}) _ = return $ CourseR courseTerm courseSchool courseShorthand CInviteR
+    invitationResolveFor = do
+      Just (CourseR tid csh ssh CInviteR) <- getCurrentRoute
+      getKeyBy404 $ TermSchoolCourseShort tid csh ssh
+    invitationSubject     Course{..} _ = return . SomeMessage $ MsgMailSubjectParticipantInvitation courseTerm courseSchool courseShorthand
+    invitationHeading     Course{..} _ = return . SomeMessage $ MsgCourseParticipantInviteHeading $ CI.original courseName
+    invitationExplanation _          _ = [ihamlet|_{SomeMessage MsgCourseParticipantInviteExplanation}|]
+    -- Keine besonderen Einschränkungen beim Einlösen der Token
+    -- ACHTUNG: Mit einem Token könnten sich deshalb mehrere Benutzer anmelden!
+    invitationTokenConfig _ _ = do
+      itAuthority <- liftHandlerT requireAuthId
+      return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
+    invitationRestriction _ _ = return Authorized
+    invitationForm Course{..} _ uid = hoistAForm lift . wFormToAForm $ do
+      now <- liftIO getCurrentTime
+      studyFeatures <- wreq (studyFeaturesPrimaryFieldFor False [] $ Just uid)
+          (fslI MsgCourseStudyFeature & setTooltip MsgCourseStudyFeatureTooltip) Nothing
+      return $ JunctionParticipant <$> pure now <*> studyFeatures
+    invitationSuccessMsg Course{..} _ =
+      return . SomeMessage $ MsgCourseParticipantInvitationAccepted (CI.original courseName)
+    invitationUltDest Course{..} _ = return . SomeRoute $ CourseR courseTerm courseSchool courseShorthand CShowR
+
+data AddRecipientsResult = AddRecipientsResult
+  { aurAlreadyRegistered
+  , aurNoUniquePrimaryField
+  , aurSuccess              :: [UserEmail]
+  } deriving (Read, Show, Generic, Typeable)
+
+instance Monoid AddRecipientsResult where
+  mempty = memptydefault
+  mappend = mappenddefault
+
+getCAddUserR, postCAddUserR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
+getCAddUserR = postCAddUserR
+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) Nothing
+
+    formResultModal usersToEnlist (CourseR tid ssh csh CUsersR) $ processUsers 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
+        }
+  where
+    processUsers :: CourseId -> Set (Either UserEmail UserId) -> WriterT [Message] Handler ()
+    processUsers cid users = do
+      let (emails,uids) = partitionEithers $ Set.toList users
+      AddRecipientsResult alreadyRegistered registeredNoField registeredOneField <- lift . runDBJobs $ do
+        -- send Invitation eMails to unkown users
+        sinkInvitationsF participantInvitationConfig [(mail,cid,(InvDBDataParticipant,InvTokenDataParticipant)) | mail <- emails]
+        -- register known users
+        execWriterT $ mapM (registerUser cid) uids
+
+      when (not $ null emails) $
+        tell . pure <=< messageI Success . MsgCourseParticipantsInvited $ length emails
+
+      when (not $ null alreadyRegistered) $ do
+        let modalTrigger = [whamlet|_{MsgCourseParticipantsAlreadyRegistered (length alreadyRegistered)}|]
+            modalContent = $(widgetFile "messages/courseInvitationAlreadyRegistered")
+        tell . pure <=< messageWidget Info $ msgModal modalTrigger (Right modalContent)
+
+      when (not $ null registeredNoField) $ do
+        let modalTrigger = [whamlet|_{MsgCourseParticipantsRegisteredWithoutField (length registeredNoField)}|]
+            modalContent = $(widgetFile "messages/courseInvitationRegisteredWithoutField")
+        tell . pure <=< messageWidget Warning $ msgModal modalTrigger (Right modalContent)
+
+      when (not $ null registeredOneField) $
+        tell . pure <=< messageI Success . MsgCourseParticipantsRegistered $ length registeredOneField
+
+    registerUser :: CourseId -> UserId -> WriterT AddRecipientsResult (YesodJobDB UniWorX) ()
+    registerUser cid uid = exceptT tell tell $ do
+      User{..} <- lift . lift $ getJust uid
+
+      whenM (lift . lift . existsBy $ UniqueParticipant uid cid) $
+        throwError $ mempty { aurAlreadyRegistered = pure userEmail }
+
+      features <- lift . lift $ selectKeysList [ StudyFeaturesUser ==. uid, StudyFeaturesValid ==. True, StudyFeaturesType ==. FieldPrimary ] []
+
+      let courseParticipantField
+            | [f] <- features = Just f
+            | otherwise       = Nothing
+
+      courseParticipantRegistration <- liftIO getCurrentTime
+      void . lift . lift . insert $ CourseParticipant
+        { courseParticipantCourse = cid
+        , courseParticipantUser = uid
+        , ..
+        }
+
+      return $ case courseParticipantField of
+        Nothing -> mempty { aurNoUniquePrimaryField = pure userEmail }
+        Just _  -> mempty { aurSuccess              = pure userEmail }
+
+
+getCInviteR, postCInviteR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
+getCInviteR = postCInviteR
+postCInviteR = invitationR participantInvitationConfig

src/Handler/Sheet.hs

@@ -857,7 +857,7 @@ correctorInvitationConfig = InvitationConfig{..}
       itAuthority <- liftHandlerT requireAuthId
       return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
     invitationRestriction _ _ = return Authorized
-    invitationForm _ (InvDBDataSheetCorrector load state, _) = pure $ JunctionSheetCorrector load state
+    invitationForm _ (InvDBDataSheetCorrector load state, _) _ = pure $ JunctionSheetCorrector load state
     invitationSuccessMsg Sheet{..} _ = return . SomeMessage $ MsgCorrectorInvitationAccepted sheetName
     invitationUltDest Sheet{..} _ = do
       Course{..} <- get404 sheetCourse

src/Handler/Submission.hs

@@ -113,7 +113,7 @@ submissionUserInvitationConfig = InvitationConfig{..}
           itStartsAt = Nothing
       return InvitationTokenConfig{..}
     invitationRestriction _ _ = return Authorized
-    invitationForm _ _ = pure JunctionSubmissionUser
+    invitationForm _ _ _ = pure JunctionSubmissionUser
     invitationSuccessMsg Submission{..} _ = do
       Sheet{..} <- getJust submissionSheet
       return . SomeMessage $ MsgSubmissionUserInvitationAccepted sheetName

src/Handler/Tutorial.hs

@@ -260,7 +260,7 @@ tutorInvitationConfig = InvitationConfig{..}
       itAuthority <- liftHandlerT requireAuthId
       return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
     invitationRestriction _ _ = return Authorized
-    invitationForm _ _ = pure JunctionTutor
+    invitationForm _ _ _ = pure JunctionTutor
     invitationSuccessMsg Tutorial{..} _ = return . SomeMessage $ MsgCorrectorInvitationAccepted tutorialName
     invitationUltDest Tutorial{..} _ = do
       Course{..} <- get404 tutorialCourse

src/Handler/Utils/Invitations.hs

@@ -129,7 +129,7 @@ data InvitationConfig junction = InvitationConfig
     -- ^ Parameters for creating the invitation token (`InvitationTokenData` is handled transparently)
   , invitationRestriction :: InvitationFor junction -> InvitationData junction -> YesodDB UniWorX AuthResult
     -- ^ Additional restrictions to check before allowing an user to redeem an invitation token
-  , invitationForm        :: InvitationFor junction -> InvitationData junction -> AForm (YesodDB UniWorX) (InvitableJunction junction)
+  , invitationForm        :: InvitationFor junction -> InvitationData junction -> Key User -> AForm (YesodDB UniWorX) (InvitableJunction junction)
     -- ^ Assimilate the additional data entered by the redeeming user
   , invitationSuccessMsg  :: InvitationFor junction -> Entity junction         -> YesodDB UniWorX (SomeMessage UniWorX)
     -- ^ What to tell the redeeming user after accepting the invitation
@@ -284,7 +284,7 @@ invitationR' InvitationConfig{..} = liftHandlerT $ do
       iData = review _InvitationData (dbData, itData)
     guardAuthResult =<< invitationRestriction fRec iData
     ((dataRes, dataWidget), dataEnctype) <- runFormPost . formEmbedJwtPost . renderAForm FormStandard . wFormToAForm $ do
-      dataRes <- aFormToWForm $ invitationForm fRec iData
+      dataRes <- aFormToWForm $ invitationForm fRec iData invitee
       btnRes <- aFormToWForm . disambiguateButtons $ combinedButtonField (BtnInviteAccept : [ BtnInviteDecline | is _Nothing $ ephemeralInvitation @junction ]) (fslI MsgInvitationAction & bool id (setTooltip MsgInvitationActionTip) (is _Nothing $ ephemeralInvitation @junction))
       case btnRes of
         FormSuccess BtnInviteDecline -> return $ FormSuccess Nothing

src/Utils/Form.hs

@@ -8,7 +8,7 @@ import Settings
 
 import Utils.Parameters
 
--- import Text.Blaze (toMarkup) -- for debugging
+import Text.Blaze (Markup)
 import qualified Text.Blaze.Internal as Blaze (null)
 import qualified Data.Text as T
 
@@ -498,6 +498,10 @@ renderAForm formLayout aform fragment = do
   let widget = $(widgetFile "widgets/aform/aform")
   return (res, widget)
 
+renderWForm :: MonadHandler m => FormLayout -> WForm m (FormResult a) -> -- Form a   -- (Synonym unavailable here)
+  (Markup -> MForm m (FormResult a, WidgetT (HandlerSite m) IO ()))
+renderWForm formLayout = renderAForm formLayout . wFormToAForm
+
 
 -- | special id to identify form section headers, see 'aformSection' and 'formSection'
 --   currently only treated by form generation through 'renderAForm'

src/Utils/Frontend/Modal.hs

@@ -1,7 +1,7 @@
 module Utils.Frontend.Modal
   ( Modal(..)
   , customModal
-  , modal
+  , modal, msgModal
   ) where
 
 import ClassyPrelude.Yesod
@@ -11,6 +11,9 @@ import Utils.Route
 
 import Settings (widgetFile)
 
+import Control.Monad.Random.Class (MonadRandom(..))
+import qualified Data.UUID as UUID
+
 
 data Modal site = Modal
   { modalTriggerId
@@ -37,3 +40,15 @@ modal modalTrigger' modalContent = customModal Modal{..}
     modalTriggerId = Nothing
     modalId = Nothing
     modalTrigger mRoute triggerId = $(widgetFile "widgets/modal/trigger")
+
+
+-- | Variant of `modal` for use in messages (uses a different id generator to avoid collisions)
+msgModal :: WidgetT site IO ()
+         -> Either (SomeRoute site) (WidgetT site IO ())
+         -> WidgetT site IO ()
+msgModal modalTrigger' modalContent = do
+  modalTriggerId <- Just . UUID.toText <$> liftIO getRandom
+  modalId <- Just . UUID.toText <$> liftIO getRandom
+  customModal Modal{..}
+  where
+    modalTrigger mRoute triggerId = $(widgetFile "widgets/modal/trigger")

templates/messages/courseInvitationAlreadyRegistered.hamlet

@@ -0,0 +1,5 @@
+<h2>
+  _{MsgCourseParticipantsAlreadyRegistered (length alreadyRegistered)}
+<ul>
+  $forall email <- alreadyRegistered
+    <li style="font-family: monospace">#{email}

templates/messages/courseInvitationRegisteredWithoutField.hamlet

@@ -0,0 +1,5 @@
+<h2>
+  _{MsgCourseParticipantsRegisteredWithoutField (length registeredNoField)}
+<ul>
+  $forall email <- registeredNoField
+    <li style="font-family: monospace">#{email}