Finish implementation of course participant invitations

Fixes #250
2019-05-13 00:17:12 +02:00 · 2019-05-13 00:17:12 +02:00 · 487c46a1ce
commit 487c46a1ce
parent 6daaf68949
6 changed files with 126 additions and 27 deletions
--- a/messages/uniworx/de.msg
+++ b/messages/uniworx/de.msg
@ -745,6 +745,7 @@ MenuLogin: Login
 MenuLogout: Logout
 MenuCourseList: Kurse
 MenuCourseMembers: Kursteilnehmer
+MenuCourseAddMembers: Kursteilnehmer hinzufügen
 MenuCourseCommunication: Kursmitteilung
 MenuTermShow: Semester
 MenuSubmissionDelete: Abgabe löschen
@ -860,6 +861,8 @@ CourseParticipantInviteExplanation: Sie wurden eingeladen, an einem Kurs teilzun
 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
@ -951,3 +954,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
--- a/src/Foundation.hs
+++ b/src/Foundation.hs
@ -1248,7 +1248,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
@ -1417,6 +1417,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)
@ -1955,6 +1957,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
--- a/src/Handler/Course.hs
+++ b/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)
@ -704,7 +709,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
@ -1408,52 +1413,100 @@ participantInvitationConfig = InvitationConfig{..}
      getKeyBy404 $ TermSchoolCourseShort tid csh ssh
    invitationSubject     Course{..} _ = return . SomeMessage $ MsgMailSubjectParticipantInvitation courseTerm courseSchool courseShorthand
    invitationHeading     Course{..} _ = return . SomeMessage $ MsgCourseParticipantInviteHeading $ CI.original courseName
-    invitationExplanation _          _ = [ihamlet|_{SomeMessage MsgParticipantInviteExplanation}|]
+    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 = wFormToAForm $ do
+    invitationForm Course{..} _ uid = hoistAForm lift . wFormToAForm $ do
      now <- liftIO getCurrentTime
      studyFeatures <- wreq (studyFeaturesPrimaryFieldFor [ ] (Just uid))
          (fslI MsgCourseStudyFeature & setTooltip  MsgCourseStudyFeatureTooltip) Nothing
      return $ JunctionParticipant <$> pure now <*> studyFeatures
-    invitationSuccessMsg Course{..} _ =
-      return . SomeMessage $ MsgParticipantInvitationAccepted courseTerm courseSchool courseShorthand
+    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 <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
-    ((usersToEnlist,formWgt),formEcnoding) <- runFormPost . renderWForm FormStandard $ do
-      enlist <- wreq checkBoxField  (fslI MsgCourseParticipantEnlistDirectly) (Just False)
-      areq (multiUserField (fromMaybe False $ formResultToMaybe enlist)  Nothing)
+    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
-    formResult usersToEnlist processUsers
+
+    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 :: Set (Either UserEmail UserId) -> Handler ()
-    processUsers users = do
-      error "TODO"
-      {-}
-      let (emails,uids) = partionEithers $ Set.toList users
-      runDB $ do
+    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
-        (alreadyRegistered,registeredNoField,registeredOneField) <- execWriterT $ mapM registerUser uids
-      let statusMsg = modal _linkText (Right _widgetmessage)
-          statusTy  = Info -- Success -- TODO
-      addMessageWidget statusTy statusMsg
-      redirect $ CourseR tid ssh csh CUsersR
+        execWriterT $ mapM (registerUser cid) uids

-    registerUser :: UserId -> WriterT ([UserEmail],[UserEmail],[UserEmail]) (YesodDB UniWorX) ()
-    registerUser uid = do
+      when (not $ null emails) $
+        tell . pure <=< messageI Success . MsgCourseParticipantsInvited $ length emails

-      tell ([],[],[])
-      -}
+      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
--- a/src/Utils/Frontend/Modal.hs
+++ b/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")
--- a/templates/messages/courseInvitationAlreadyRegistered.hamlet
+++ b/templates/messages/courseInvitationAlreadyRegistered.hamlet
@ -0,0 +1,5 @@
+<h2>
+  _{MsgCourseParticipantsAlreadyRegistered (length alreadyRegistered)}
+<ul>
+  $forall email <- alreadyRegistered
+    <li style="font-family: monospace">#{email}
--- a/templates/messages/courseInvitationRegisteredWithoutField.hamlet
+++ b/templates/messages/courseInvitationRegisteredWithoutField.hamlet
@ -0,0 +1,5 @@
+<h2>
+  _{MsgCourseParticipantsRegisteredWithoutField (length registeredNoField)}
+<ul>
+  $forall email <- registeredNoField
+    <li style="font-family: monospace">#{email}