Implement lecturer invitations with new system

messages/uniworx/de.msg

@@ -801,3 +801,5 @@ InvitationCollision: Einladung konnte nicht angenommen werden da ein derartiger
 InvitationDeclined: Einladung wurde abgelehnt
 BtnInviteAccept: Einladung annehmen
 BtnInviteDecline: Einladung ablehnen
+
+LecturerType: Rolle

routes

@@ -76,7 +76,7 @@
   /                           CShowR          GET             !free
   /register                   CRegisterR          POST        !timeANDcapacity
   /edit                       CEditR          GET POST
-  /lecturer-invite/#UserEmail CLecInviteR     GET POST
+  /lecturer-invite            CLecInviteR     GET POST
   /delete                     CDeleteR        GET POST        !lecturerANDempty
   /users                      CUsersR         GET POST
   /users/#CryptoUUIDUser      CUserR          GET POST        !lecturerANDparticipant

src/Handler/Course.hs

@@ -15,6 +15,7 @@ import Handler.Utils.Delete
 import Handler.Utils.Database
 import Handler.Utils.Table.Cells
 import Handler.Utils.Table.Columns
+import Handler.Utils.Invitations
 import Database.Persist.Sql (deleteWhereCount)
 import qualified Database.Esqueleto.Utils as E
 import Database.Esqueleto.Utils.TH
@@ -37,6 +38,11 @@ import Text.Blaze.Html.Renderer.Text (renderHtml)
 
 import Jobs.Queue
 
+import Data.Aeson hiding (Result(..))
+
+import Text.Hamlet (ihamlet)
+  
+
 -- NOTE: Outdated way to use dbTable; see ProfileDataR Handler for a more recent method.
 type CourseTableData = DBRow (Entity Course, Int, Bool, Entity School)
 
@@ -500,12 +506,10 @@ courseEditHandler miButtonAction mbCourseForm = do
               , courseDeregisterUntil = cfDeRegUntil res
               }
             whenIsJust insertOkay $ \cid -> do
-                forM_ (cfLecturers res) $ \case
+              let (invites, adds) = partitionEithers $ cfLecturers res
-                  Right (lid, lty) -> insert_  $ Lecturer lid cid lty
+              insertMany_ $ map (\(lid, lty) -> Lecturer lid cid lty) adds
-                  Left (lEmail, mLTy) -> do
+              sinkInvitationsF lecturerInvitationConfig $ map (\(lEmail, mLty) -> (lEmail, cid, (InvDBDataLecturer mLty, InvTokenDataLecturer))) invites
-                    insert_ $ LecturerInvitation lEmail cid mLTy
+              insert_ $ CourseEdit aid now cid
-                    queueDBJob . JobLecturerInvitation aid $ LecturerInvitation lEmail cid mLTy
-                insert_ $ CourseEdit aid now cid
             return insertOkay
           case insertOkay of
             Just _ -> do
@@ -545,16 +549,11 @@ courseEditHandler miButtonAction mbCourseForm = do
                   (Just _) -> addMessageI Warning (MsgCourseEditDupShort tid ssh csh) $> False
                   Nothing  -> do
                     deleteWhere [LecturerCourse ==. cid]
-                    deleteWhere [LecturerInvitationCourse ==. cid, LecturerInvitationEmail /<-. toListOf (folded . _Left . _1) (cfLecturers res)]
+                    deleteWhere [InvitationFor ==. invRef @Lecturer cid, InvitationEmail /<-. toListOf (folded . _Left . _1) (cfLecturers res)]
-                    forM_ (cfLecturers res) $ \case
+                    let (invites, adds) = partitionEithers $ cfLecturers res
-                      Right (lid, lty) -> insert_  $ Lecturer lid cid lty
+                    insertMany_ $ map (\(lid, lty) -> Lecturer lid cid lty) adds
-                      Left (lEmail, mLTy) -> do
+                    sinkInvitationsF lecturerInvitationConfig $ map (\(lEmail, mLty) -> (lEmail, cid, (InvDBDataLecturer mLty, InvTokenDataLecturer))) invites
-                        insertRes <- insertUnique (LecturerInvitation lEmail cid mLTy)
+
-                        case insertRes of
-                          Just _  ->
-                            queueDBJob . JobLecturerInvitation aid $ LecturerInvitation lEmail cid mLTy
-                          Nothing -> 
-                            updateBy (UniqueLecturerInvitation lEmail cid) [ LecturerInvitationType =. mLTy ]
                     insert_ $ CourseEdit aid now cid
                     addMessageI Success $ MsgCourseEditOk tid ssh csh
                     return True
@@ -568,6 +567,65 @@ courseEditHandler miButtonAction mbCourseForm = do
         }
 
 
+instance IsInvitableJunction Lecturer where
+  type InvitationFor Lecturer = Course
+  data InvitableJunction Lecturer = JunctionLecturer
+    { jLecturerType :: LecturerType
+    } deriving (Eq, Ord, Read, Show, Generic, Typeable)
+  data InvitationDBData Lecturer = InvDBDataLecturer
+    { invDBLecturerType :: Maybe LecturerType
+    } deriving (Eq, Ord, Read, Show, Generic, Typeable)
+  data InvitationTokenData Lecturer = InvTokenDataLecturer
+    deriving (Eq, Ord, Read, Show, Generic, Typeable)
+
+  _InvitableJunction = iso
+    (\Lecturer{..} -> (lecturerUser, lecturerCourse, JunctionLecturer lecturerType))
+    (\(lecturerUser, lecturerCourse, JunctionLecturer lecturerType) -> Lecturer{..})
+
+instance ToJSON (InvitableJunction Lecturer) where
+  toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
+  toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
+instance FromJSON (InvitableJunction Lecturer) where
+  parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
+
+instance ToJSON (InvitationDBData Lecturer) where
+  toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 3 }
+  toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 3 }
+instance FromJSON (InvitationDBData Lecturer) where
+  parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 3 }
+
+instance ToJSON (InvitationTokenData Lecturer) where
+  toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
+  toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 3 }
+instance FromJSON (InvitationTokenData Lecturer) where
+  parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
+
+lecturerInvitationConfig :: InvitationConfig Lecturer
+lecturerInvitationConfig = InvitationConfig{..}
+  where
+    invitationRoute Course{..} _ = return . CourseR courseTerm courseSchool courseShorthand $ CLecInviteR
+    invitationResolveFor = do
+      Just (CourseR tid csh ssh CLecInviteR) <- getCurrentRoute
+      getKeyBy404 $ TermSchoolCourseShort tid csh ssh
+    invitationSubject Course{..} _ = SomeMessage $ MsgMailSubjectLecturerInvitation courseTerm courseSchool courseShorthand
+    invitationHeading Course{..} _ = SomeMessage $ MsgCourseLecInviteHeading $ CI.original courseName
+    invitationExplanation _ _ = [ihamlet|_{SomeMessage MsgCourseLecInviteExplanation}|]
+    invitationTokenConfig _ _ = do
+      itAuthority <- liftHandlerT requireAuthId
+      return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
+    invitationRestriction _ _ = return Authorized
+    invitationForm _ (InvDBDataLecturer mlType, _) = hoistAForm liftHandlerT $ toJunction <$> case mlType of
+      Nothing    -> areq    (selectField optionsFinite) lFs Nothing
+      Just lType -> aforced (selectField optionsFinite) lFs lType
+      where
+        toJunction jLecturerType = JunctionLecturer{..}
+        lFs = fslI MsgLecturerType & setTooltip MsgCourseLecturerRightsIdentical
+    invitationSuccessMsg Course{..} (Entity _ Lecturer{..}) = do
+      MsgRenderer mr <- getMsgRenderer
+      return . SomeMessage $ MsgLecturerInvitationAccepted (mr lecturerType) courseShorthand
+    invitationUltDest Course{..} _ = return . SomeRoute $ CourseR courseTerm courseSchool courseShorthand CShowR
+
+
 data CourseForm = CourseForm
         { cfCourseId   :: Maybe CourseId
         , cfName       :: CourseName
@@ -1131,54 +1189,6 @@ postCCommR tid ssh csh = do
     }
 
  
-data ButtonLecInvite = BtnLecInvAccept | BtnLecInvDecline
+getCLecInviteR, postCLecInviteR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
-  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
-instance Universe ButtonLecInvite
-instance Finite ButtonLecInvite
-
-nullaryPathPiece ''ButtonLecInvite $ camelToPathPiece' 3
-embedRenderMessage ''UniWorX ''ButtonLecInvite id
-
-instance Button UniWorX ButtonLecInvite where
-  btnClasses BtnLecInvAccept = [BCIsButton, BCPrimary]
-  btnClasses BtnLecInvDecline = [BCIsButton, BCDanger]
-
-getCLecInviteR, postCLecInviteR :: TermId -> SchoolId -> CourseShorthand -> UserEmail -> Handler Html
 getCLecInviteR = postCLecInviteR
-postCLecInviteR tid ssh csh email = do
+postCLecInviteR = invitationR lecturerInvitationConfig
-  uid <- requireAuthId
-  (Entity cid Course{..}, Entity liId LecturerInvitation{..}) <- runDB $ do
-    cRes@(Entity cid _) <- getBy404 $ TermSchoolCourseShort tid ssh csh
-    iRes <- getBy404 $ UniqueLecturerInvitation email cid
-    return (cRes, iRes)
-
-  ((btnResult, btnInnerWidget), btnEncoding) <- runFormPost . formEmbedJwtPost $ \csrf -> do
-    (ltRes, ltView) <- case lecturerInvitationType of
-      Nothing -> mreq (selectField optionsFinite) "" Nothing
-      Just lType -> mforced (selectField optionsFinite) "" lType
-    (btnRes, btnWdgt) <- buttonForm mempty
-    return ((,) <$> ltRes <*> btnRes, toWidget csrf <> fvInput ltView <> btnWdgt)
-
-  let btnWidget = wrapForm btnInnerWidget def
-        { formEncoding = btnEncoding
-        , formAction = Just . SomeRoute . CourseR tid ssh csh $ CLecInviteR email
-        , formSubmit = FormNoSubmit
-        }
-
-  formResult btnResult $ \case
-    (lType, BtnLecInvAccept) -> do
-      runDB $ do
-        delete liId
-        insert_ $ Lecturer uid cid lType
-      MsgRenderer mr <- getMsgRenderer
-      addMessageI Success $ MsgLecturerInvitationAccepted (mr lType) csh
-      redirect $ CourseR tid ssh csh CShowR
-    (_, BtnLecInvDecline) -> do
-      runDB $
-        delete liId
-      addMessageI Info $ MsgLecturerInvitationDeclined csh
-      redirect HomeR
-
-  siteLayoutMsg (MsgCourseLecInviteHeading $ CI.original courseName) $ do
-    setTitleI . MsgCourseLecInviteHeading $ CI.original courseName
-    $(widgetFile "courseLecInvite")

src/Handler/Utils/Invitations.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
 
 module Handler.Utils.Invitations
   ( -- * Procedure
@@ -6,9 +7,10 @@ module Handler.Utils.Invitations
     -- $procedure
     IsInvitableJunction(..)
   , _invitationDBData, _invitationTokenData
+  , InvitationReference(..), invRef
   , InvitationConfig(..), InvitationTokenConfig(..)
   , sinkInvitations, sinkInvitationsF
-  , invitationR
+  , invitationR', InvitationR(..)
   ) where
 
 import Import
@@ -30,11 +32,15 @@ import Data.Aeson (fromJSON)
 import qualified Data.Aeson as JSON
 import Data.Aeson.TH
 
+import Data.Proxy (Proxy(..))
+import Data.Typeable
+
 
 class ( PersistRecordBackend junction (YesodPersistBackend UniWorX)
       , ToJSON (InvitationDBData junction), ToJSON (InvitationTokenData junction)
       , FromJSON (InvitationDBData junction), FromJSON (InvitationTokenData junction)
       , PersistRecordBackend (InvitationFor junction) (YesodPersistBackend UniWorX)
+      , Typeable junction
       ) => IsInvitableJunction junction where
   -- | One side of the junction is always `User`; `InvitationFor junction` is the other
   type InvitationFor       junction :: *
@@ -72,6 +78,32 @@ _invitationTokenData :: IsInvitableJunction junction => Lens' (InvitationData ju
 _invitationTokenData = _InvitationData . _2
 
 
+data InvitationReference junction = IsInvitableJunction junction => InvRef (Key (InvitationFor junction))
+
+deriving instance Eq (InvitationReference junction)
+deriving instance Ord (InvitationReference junction)
+deriving instance IsInvitableJunction junction => Read (InvitationReference junction)
+deriving instance Show (InvitationReference junction)
+
+instance ToJSON (InvitationReference junction) where
+  toJSON (InvRef fId) = JSON.object
+    [ "type" JSON..= show (typeRep (Proxy @junction))
+    , "key"  JSON..= fId
+    ]
+instance IsInvitableJunction junction => FromJSON (InvitationReference junction) where
+  parseJSON = JSON.withObject "InvitationReference" $ \o -> do
+    table <- o JSON..: "type"
+    key   <- o JSON..: "key"
+
+    unless (table == show (typeRep (Proxy @junction))) $
+      fail "Unexpected table"
+
+    return $ InvRef key
+
+invRef :: forall junction. IsInvitableJunction junction => Key (InvitationFor junction) -> JSON.Value
+invRef = toJSON . InvRef @junction
+
+
 -- | Configuration needed for creating and accepting/declining `Invitation`s
 --
 -- It is advisable to define this once per `junction` in a global constant
@@ -147,13 +179,13 @@ sinkInvitations InvitationConfig{..} = determineExists .| C.foldMap pure >>= lif
       = C.map Right
       | otherwise
       = C.mapM $ \inp@(email, fid, dat) ->
-          maybe (Right inp) (Left . (, dat)) <$> getKeyBy (UniqueInvitation email (toJSON fid))
+          maybe (Right inp) (Left . (, dat)) <$> getKeyBy (UniqueInvitation email (toJSON $ InvRef @junction fid))
 
     sinkInvitations' :: [Either (InvitationId, InvitationData junction) (UserEmail, Key (InvitationFor junction), InvitationData junction)]
                      -> YesodJobDB UniWorX ()
     sinkInvitations' (partitionEithers -> (existing, new)) = do
       when (is _Nothing (ephemeralInvitation @junction)) $ do
-        insertMany_ $ map (\(email, fid, dat) -> Invitation email (toJSON fid) (toJSON $ dat ^. _invitationDBData)) new
+        insertMany_ $ map (\(email, fid, dat) -> Invitation email (toJSON $ InvRef @junction fid) (toJSON $ dat ^. _invitationDBData)) new
         forM_ existing $ \(iid, dat) -> update iid [ InvitationData =. toJSON (dat ^. _invitationDBData) ]
       forM_ new $ \(jInvitee, fid, dat) -> do
         app <- getYesod
@@ -201,15 +233,15 @@ instance Button UniWorX ButtonInvite where
   btnValidate _ BtnInviteAccept  = True
   btnValidate _ BtnInviteDecline = False
 
-invitationR :: forall junction m.
+invitationR' :: forall junction m.
-               ( IsInvitableJunction junction
+                ( IsInvitableJunction junction
-               , MonadHandler m
+                , MonadHandler m
-               , HandlerSite m ~ UniWorX
+                , HandlerSite m ~ UniWorX
-               )
+                )
-            => InvitationConfig junction
+             => InvitationConfig junction
-            -> m Html
+             -> m Html
 -- | Generic handler for incoming invitations
-invitationR InvitationConfig{..} = liftHandlerT $ do
+invitationR' InvitationConfig{..} = liftHandlerT $ do
   InvitationTokenRestriction{..} <- maybeM (invalidArgsI [MsgInvitationMissingRestrictions]) return currentTokenRestrictions :: Handler (InvitationTokenRestriction junction)
   invitee <- requireAuthId
   Just cRoute <- getCurrentRoute
@@ -218,7 +250,7 @@ invitationR InvitationConfig{..} = liftHandlerT $ do
     Entity fid fRec <- invitationResolveFor >>= (\k -> Entity k <$> get404 k)
     dbData <- case ephemeralInvitation @junction of
       Nothing -> do
-        Invitation{..} <- entityVal <$> getBy404 (UniqueInvitation itEmail $ toJSON fid)
+        Invitation{..} <- entityVal <$> getBy404 (UniqueInvitation itEmail . toJSON $ InvRef @junction fid)
         case fromJSON invitationData of
           JSON.Success dbData -> return dbData
           JSON.Error   str    -> fail $ "Could not decode invitationData: " <> str
@@ -243,7 +275,7 @@ invitationR InvitationConfig{..} = liftHandlerT $ do
     fmap (, (dataWidget, dataEnctype), heading, explanation) . formResultMaybe dataRes $ \case
       Nothing -> do
         addMessageI Info MsgInvitationDeclined
-        deleteBy . UniqueInvitation itEmail $ toJSON fid
+        deleteBy . UniqueInvitation itEmail . toJSON $ InvRef @junction fid
         return . Just $ SomeRoute HomeR
       Just jData -> do
         mResult <- insertUniqueEntity $ review _InvitableJunction (invitee, fid, jData)
@@ -265,6 +297,20 @@ invitationR InvitationConfig{..} = liftHandlerT $ do
   siteLayoutMsg heading $(widgetFile "widgets/invitation-site")
 
 
+class InvitationR a where
+  invitationR :: forall junction.
+                ( IsInvitableJunction junction
+                )
+              => InvitationConfig junction
+              -> a
+
+instance InvitationR (Handler Html) where
+  invitationR = invitationR'
+
+instance InvitationR b => InvitationR (a -> b) where
+  invitationR cfg _ = invitationR cfg
+  
+
 -- $procedure
 --
 -- `Invitation`s encode a pending entry of some junction table between some

src/Jobs.hs

@@ -60,7 +60,6 @@ import Jobs.Handler.HelpRequest
 import Jobs.Handler.SetLogSettings
 import Jobs.Handler.DistributeCorrections
 import Jobs.Handler.SendCourseCommunication
-import Jobs.Handler.LecturerInvitation
 import Jobs.Handler.CorrectorInvitation
 import Jobs.Handler.Invitation
 

src/Jobs/Handler/LecturerInvitation.hs

@@ -1,41 +0,0 @@
-module Jobs.Handler.LecturerInvitation
-  ( dispatchJobLecturerInvitation
-  ) where
-
-import Import
-
-import Text.Hamlet
-
-import qualified Data.HashSet as HashSet
-
-import qualified Data.CaseInsensitive as CI
-
-import Utils.Lens
-
-
-dispatchJobLecturerInvitation :: UserId -> LecturerInvitation -> Handler ()
-dispatchJobLecturerInvitation jInviter jLecturerInvitation@LecturerInvitation{..} = do
-  ctx <- runDB . runMaybeT $ do
-    course <- MaybeT $ get lecturerInvitationCourse
-    void . MaybeT $ getByValue jLecturerInvitation
-    user <- MaybeT $ get jInviter
-    return (course, user)
-
-  case ctx of
-    Just (Course{..}, User{..}) -> do
-      let baseRoute = CourseR courseTerm courseSchool courseShorthand $ CLecInviteR lecturerInvitationEmail
-      jwt <- encodeToken =<< bearerToken jInviter (Just $ HashSet.singleton baseRoute) Nothing Nothing Nothing
-      let
-        invitationUrl :: SomeRoute UniWorX
-        invitationUrl = SomeRoute (baseRoute, [(toPathPiece GetBearer, toPathPiece jwt)])
-      invitationUrl' <- toTextUrl invitationUrl
-
-      mailT def $ do
-        _mailTo .= [Address Nothing $ CI.original lecturerInvitationEmail]
-        replaceMailHeader "Reply-To" . Just . renderAddress $ Address (Just userDisplayName) (CI.original userEmail)
-        replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
-        setSubjectI $ MsgMailSubjectLecturerInvitation courseTerm courseSchool courseShorthand
-      
-        addPart ($(ihamletFile "templates/mail/lecturerInvitation.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))
-    Nothing -> runDB .
-      deleteBy $ UniqueLecturerInvitation lecturerInvitationEmail lecturerInvitationCourse

src/Jobs/Types.hs

@@ -31,9 +31,6 @@ data Job = JobSendNotification { jRecipient :: UserId, jNotification :: Notifica
                                       , jSubject :: Maybe Text
                                       , jMailContent :: Html
                                       }
-         | JobLecturerInvitation { jInviter :: UserId
-                                 , jLecturerInvitation :: LecturerInvitation
-                                 }
          | JobCorrectorInvitation { jInviter :: UserId
                                   , jCorrectorInvitation :: SheetCorrectorInvitation
                                   }

templates/courseLecInvite.hamlet

@@ -1,3 +0,0 @@
-<p>
-  _{MsgCourseLecInviteExplanation}
-^{btnWidget}