initial stub, does not compile

messages/uniworx/de.msg

@@ -582,6 +582,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}
@@ -853,6 +855,12 @@ 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
+
+
 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}

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/Handler/Course.hs

@@ -1359,3 +1359,103 @@ 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 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 MsgParticipantInviteExplanation}|]
+    -- 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
+      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
+    invitationUltDest Course{..} _ = return . SomeRoute $ CourseR courseTerm courseSchool courseShorthand CShowR
+
+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)
+              (fslI MsgCourseParticipantInviteField) Nothing
+    formResult usersToEnlist processUsers
+  where
+    processUsers :: Set (Either UserEmail UserId) -> Handler ()
+    processUsers users = do
+      error "TODO"
+      {-}
+      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
+      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) ()
+    registerUser uid = do
+
+      tell ([],[],[])
+      -}
+
+
+getCInviteR, postCInviteR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
+getCInviteR = postCInviteR
+postCInviteR = invitationR participantInvitationConfig

src/Handler/Sheet.hs

@@ -836,7 +836,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/Tutorial.hs

@@ -249,7 +249,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'