Finish implementation of course participant invitations

Fixes #250

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

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

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{..} _ =
+    invitationSuccessMsg Course{..} _ =
-      return . SomeMessage $ MsgParticipantInvitationAccepted courseTerm courseSchool courseShorthand
+      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
+    cid <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh
-    ((usersToEnlist,formWgt),formEcnoding) <- runFormPost . renderWForm FormStandard $ do
+    ((usersToEnlist,formWgt),formEncoding) <- runFormPost . renderWForm FormStandard $ do
-      enlist <- wreq checkBoxField  (fslI MsgCourseParticipantEnlistDirectly) (Just False)
+      enlist <- wreq checkBoxField (fslI MsgCourseParticipantEnlistDirectly) (Just False)
-      areq (multiUserField (fromMaybe False $ formResultToMaybe enlist)  Nothing)
+      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 :: CourseId -> Set (Either UserEmail UserId) -> WriterT [Message] Handler ()
-    processUsers users = do
+    processUsers cid users = do
-      error "TODO"
+      let (emails,uids) = partitionEithers $ Set.toList users
-      {-}
+      AddRecipientsResult alreadyRegistered registeredNoField registeredOneField <- lift . runDBJobs $ do
-      let (emails,uids) = partionEithers $ Set.toList users
-      runDB $ 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
+        execWriterT $ mapM (registerUser cid) uids
-      let statusMsg = modal _linkText (Right _widgetmessage)
-          statusTy  = Info -- Success -- TODO
-      addMessageWidget statusTy statusMsg
-      redirect $ CourseR tid ssh csh CUsersR
 
-    registerUser :: UserId -> WriterT ([UserEmail],[UserEmail],[UserEmail]) (YesodDB UniWorX) ()
+      when (not $ null emails) $
-    registerUser uid = do
+        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

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}