From cb6aedd3ee5a1aab430832a39071fbea706c8158 Mon Sep 17 00:00:00 2001 From: Filip Gralinski Date: Sat, 13 Mar 2021 11:16:54 +0100 Subject: [PATCH] A team captain cain invite other members --- Handler/AccountReset.hs | 11 +- Handler/Team.hs | 162 ++++++++++++++++++++--- PersistTeamActionType.hs | 2 +- config/models | 2 + config/routes | 2 + messages/en.msg | 2 + templates/invitation-link-created.hamlet | 4 + templates/my-teams.hamlet | 2 + templates/receive-invitation-link.hamlet | 4 + templates/team-invitation-form.hamlet | 4 + templates/team-invitation.hamlet | 4 + 11 files changed, 173 insertions(+), 26 deletions(-) create mode 100644 templates/invitation-link-created.hamlet create mode 100644 templates/receive-invitation-link.hamlet create mode 100644 templates/team-invitation-form.hamlet create mode 100644 templates/team-invitation.hamlet diff --git a/Handler/AccountReset.hs b/Handler/AccountReset.hs index c28be98..a89b9bf 100644 --- a/Handler/AccountReset.hs +++ b/Handler/AccountReset.hs @@ -28,6 +28,13 @@ postCreateResetLinkR = do _ -> Nothing doCreateResetLink mUserIdentifier mCourseId +createLinkToken :: Handler (Text, UTCTime) +createLinkToken = do + key <- newToken + theNow <- liftIO getCurrentTime + let expirationMoment = addUTCTime (60*60*24) theNow + return (key, expirationMoment) + doCreateResetLink :: Maybe Text -> Maybe CourseId -> Handler Html doCreateResetLink (Just userIdentifier) mCourseId = do mUserEnt <- runDB $ getBy $ UniqueUser userIdentifier @@ -35,9 +42,7 @@ doCreateResetLink (Just userIdentifier) mCourseId = do addParticipant userId mCourseId - key <- newToken - theNow <- liftIO getCurrentTime - let expirationMoment = addUTCTime (60*60*24) theNow + (key, expirationMoment) <- createLinkToken runDB $ update userId [UserVerificationKey =. Just key, UserKeyExpirationDate =. Just expirationMoment] defaultLayout $ do diff --git a/Handler/Team.hs b/Handler/Team.hs index 75b86af..837a5b0 100644 --- a/Handler/Team.hs +++ b/Handler/Team.hs @@ -8,6 +8,7 @@ import Yesod.Form.Bootstrap3 (BootstrapFormLayout (..), renderBootstrap3, bfs) import Handler.Shared (fieldWithTooltip) import Handler.JWT +import Handler.AccountReset import PersistTeamActionType @@ -24,6 +25,8 @@ import Data.Proxy as DPR import Control.Lens hiding ((.=), (^.)) import Data.HashMap.Strict.InsOrd (fromList) +import qualified Data.Text as T + getMyTeamsR :: Handler Html getMyTeamsR = do _ <- requireAuth @@ -60,21 +63,7 @@ createTeam userId teamCreationData = do teamIdent = theIdent, teamAvatar = avatarBytes } - _ <- insert TeamMember { - teamMemberUser = userId, - teamMemberTeam = newTeamId, - teamMemberIsCaptain = True - } - - theNow <- liftIO getCurrentTime - - _ <- insert TeamLog { - teamLogStamp = theNow, - teamLogActionType = TeamCreation, - teamLogAgens = userId, - teamLogPatiens = Nothing, - teamLogVerificationKey = Nothing - } + addMemberToTeam userId newTeamId True return () @@ -102,6 +91,7 @@ instance ToSchema TeamMemberView where & required .~ [ "name", "isCaptain" ] data TeamView = TeamView { + teamViewId :: TeamId, teamViewIdent :: Text, teamViewMembers :: [TeamMemberView] } deriving (Eq, Show) @@ -124,9 +114,15 @@ instance ToSchema TeamView where ] & required .~ [ "ident", "members" ] +invitation :: TeamId -> WidgetFor App () +invitation teamId = do + (formWidget, formEnctype) <- handlerToWidget $ generateFormPost $ teamInvitationForm $ Just teamId + $(widgetFile "team-invitation-form") + doMyTeams :: Handler Html doMyTeams = do (formWidget, formEnctype) <- generateFormPost createTeamForm + teams <- fetchMyTeams defaultLayout $ do setTitle "Teams" @@ -160,9 +156,9 @@ fetchMyTeams :: Handler [TeamView] fetchMyTeams = do Entity userId _ <- requireAuthPossiblyByToken - myTeams <- runDB $ E.select $ E.from $ \(team, member) -> do - E.where_ (member ^. TeamMemberTeam E.==. team ^. TeamId - E.&&. member ^. TeamMemberUser E.==. E.val userId) + myTeams <- runDB $ E.select $ E.from $ \(team, tmember) -> do + E.where_ (tmember ^. TeamMemberTeam E.==. team ^. TeamId + E.&&. tmember ^. TeamMemberUser E.==. E.val userId) E.orderBy [E.asc (team ^. TeamIdent)] return team @@ -173,13 +169,14 @@ fetchTeamInfo :: (YesodPersist site, PersistQueryRead (YesodPersistBackend site), PersistUniqueRead (YesodPersistBackend site)) => Entity Team -> HandlerFor site TeamView fetchTeamInfo (Entity teamId team) = do - members <- runDB $ E.select $ E.from $ \(user, member) -> do - E.where_ (member ^. TeamMemberTeam E.==. E.val teamId - E.&&. member ^. TeamMemberUser E.==. user ^. UserId) + members <- runDB $ E.select $ E.from $ \(user, tmember) -> do + E.where_ (tmember ^. TeamMemberTeam E.==. E.val teamId + E.&&. tmember ^. TeamMemberUser E.==. user ^. UserId) E.orderBy [E.asc (user ^. UserIdent)] - return (user, member) + return (user, tmember) return $ TeamView { + teamViewId = teamId, teamViewIdent = teamIdent team, teamViewMembers = map (\(u, m) -> TeamMemberView { teamMemberViewName = userIdent $ entityVal u, @@ -191,3 +188,124 @@ createTeamForm :: Form TeamCreationData createTeamForm = renderBootstrap3 BootstrapBasicForm $ TeamCreationData <$> areq textField (fieldWithTooltip MsgTeamIdent MsgTeamIdentTooltip) Nothing <*> fileAFormOpt (bfs MsgAvatar) + +teamInvitationForm :: Maybe TeamId -> Form (Text, TeamId) +teamInvitationForm teamId = renderBootstrap3 BootstrapBasicForm $ (,) + <$> areq textField (bfs MsgInviteToTeam) Nothing + <*> areq hiddenField "" teamId + +createTeamInvitationLink :: Key User -> Text -> Key Team -> HandlerFor App (Maybe Text) +createTeamInvitationLink userId ident teamId = do + result <- runDB $ selectList [TeamMemberUser ==. userId, TeamMemberIsCaptain ==. True, TeamMemberTeam ==. teamId] [] + case result of + [] -> return Nothing + _ -> do + (key, expirationMoment) <- createLinkToken + theNow <- liftIO getCurrentTime + + mInvitee <- runDB $ getBy $ UniqueUser ident + + case mInvitee of + Nothing -> do + -- we do this quietly not to leak username IDs + return () + Just (Entity inviteeId _) -> do + _ <- runDB $ insert $ TeamLog { + teamLogStamp = theNow, + teamLogActionType = TeamInvitation, + teamLogAgens = userId, + teamLogPatiens = Just inviteeId, + teamLogTeam = Just teamId, + teamLogVerificationKey = Just key, + teamLogKeyExpirationDate = Just expirationMoment } + return () + + return $ Just key + +postCreateTeamInvitationLinkR :: Handler Html +postCreateTeamInvitationLinkR = do + Entity userId _ <- requireAuthPossiblyByToken + ((result, _), _) <- runFormPost $ teamInvitationForm Nothing + + let FormSuccess (ident', teamId) = result + + let ident = T.strip ident' + + mToken <- createTeamInvitationLink userId ident teamId + + case mToken of + Just token -> do + defaultLayout $ do + setTitle "Invitation link" + $(widgetFile "invitation-link-created") + Nothing -> do + setMessage $ toHtml ("You must be a team captain to invite other people" :: Text) + doMyTeams + +checkTeamInvitationKey :: UserId -> Text -> Handler (Maybe (Entity Team, Entity User)) +checkTeamInvitationKey userId key = do + theNow <- liftIO getCurrentTime + teamLogEntry <- runDB $ selectList [TeamLogVerificationKey ==. Just key, + TeamLogPatiens ==. Just userId, + TeamLogKeyExpirationDate >. Just theNow] [] + case teamLogEntry of + [Entity _ entry] -> do + let inviterId = teamLogAgens entry + inviter <- runDB $ get404 inviterId + let (Just teamId) = teamLogTeam entry + team <- runDB $ get404 teamId + return $ Just ((Entity teamId team), (Entity inviterId inviter)) + _ -> return Nothing + +addMemberToTeam :: (MonadIO m, PersistStoreWrite backend, BaseBackend backend ~ SqlBackend) + => Key User -> Key Team -> Bool -> ReaderT backend m () +addMemberToTeam userId teamId isCaptain = do + _ <- insert TeamMember { + teamMemberUser = userId, + teamMemberTeam = teamId, + teamMemberIsCaptain = isCaptain + } + + theNow <- liftIO getCurrentTime + + _ <- insert TeamLog { + teamLogStamp = theNow, + teamLogActionType = TeamCreation, + teamLogAgens = userId, + teamLogPatiens = Nothing, + teamLogTeam = Just teamId, + teamLogVerificationKey = Nothing, + teamLogKeyExpirationDate = Nothing + } + + return () + +getTeamInvitationLinkR :: Text -> Handler Html +getTeamInvitationLinkR key = do + Entity userId _ <- requireAuthPossiblyByToken + + result <- checkTeamInvitationKey userId key + + case result of + Just (team, inviter) -> do + defaultLayout $ do + setTitle "Invitation link" + $(widgetFile "receive-invitation-link") + Nothing -> do + setMessage $ toHtml ("There is something wrong with this invitation link" :: Text) + doMyTeams + +postTeamInvitationLinkR :: Text -> Handler Html +postTeamInvitationLinkR key = do + Entity userId _ <- requireAuthPossiblyByToken + + result <- checkTeamInvitationKey userId key + + case result of + Just (team, _) -> do + runDB $ addMemberToTeam userId (entityKey team) False + setMessage $ toHtml ("You joined " <> (teamIdent $ entityVal team)) + Nothing -> do + setMessage $ toHtml ("There is something wrong with this invitation link" :: Text) + + doMyTeams diff --git a/PersistTeamActionType.hs b/PersistTeamActionType.hs index 270d17c..ab48c28 100644 --- a/PersistTeamActionType.hs +++ b/PersistTeamActionType.hs @@ -5,7 +5,7 @@ import Database.Persist.Sql import qualified Data.Text as T -data TeamActionType = TeamCreation | TeamJoining | TeamLeaving +data TeamActionType = TeamCreation | TeamJoining | TeamLeaving | TeamInvitation deriving (Eq, Show, Read) instance PersistField TeamActionType where diff --git a/config/models b/config/models index 24f7c03..cfe3d98 100644 --- a/config/models +++ b/config/models @@ -25,7 +25,9 @@ TeamLog actionType TeamActionType agens UserId patiens UserId Maybe + team TeamId Maybe verificationKey Text Maybe + keyExpirationDate UTCTime Maybe PublicKey user UserId pubkey Text diff --git a/config/routes b/config/routes index c2054c2..db256e4 100644 --- a/config/routes +++ b/config/routes @@ -31,6 +31,8 @@ /my-teams MyTeamsR GET /create-team CreateTeamR POST +/create-team-invitation-link CreateTeamInvitationLinkR POST +/invitation-link/#Text TeamInvitationLinkR GET POST /challenge/#Text ShowChallengeR GET /challenge-readme/#Text ChallengeReadmeR GET diff --git a/messages/en.msg b/messages/en.msg index 0248cec..247d793 100644 --- a/messages/en.msg +++ b/messages/en.msg @@ -103,3 +103,5 @@ TeamIdent: Team name TeamIdentTooltip: Note that it cannot be changed later YourTeams: your teams AsTeam: As team +InviteToTeam: Invite to team (give the identifier/login of a user) +Join: Join diff --git a/templates/invitation-link-created.hamlet b/templates/invitation-link-created.hamlet new file mode 100644 index 0000000..f137a8c --- /dev/null +++ b/templates/invitation-link-created.hamlet @@ -0,0 +1,4 @@ +

Send this link to #{ident} + +

+ @{TeamInvitationLinkR token} diff --git a/templates/my-teams.hamlet b/templates/my-teams.hamlet index e7c00c6..fd0d3e4 100644 --- a/templates/my-teams.hamlet +++ b/templates/my-teams.hamlet @@ -7,6 +7,8 @@ $forall team <- teams