forked from filipg/gonito
A team captain cain invite other members
This commit is contained in:
parent
c23409526d
commit
cb6aedd3ee
@ -28,6 +28,13 @@ postCreateResetLinkR = do
|
|||||||
_ -> Nothing
|
_ -> Nothing
|
||||||
doCreateResetLink mUserIdentifier mCourseId
|
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 :: Maybe Text -> Maybe CourseId -> Handler Html
|
||||||
doCreateResetLink (Just userIdentifier) mCourseId = do
|
doCreateResetLink (Just userIdentifier) mCourseId = do
|
||||||
mUserEnt <- runDB $ getBy $ UniqueUser userIdentifier
|
mUserEnt <- runDB $ getBy $ UniqueUser userIdentifier
|
||||||
@ -35,9 +42,7 @@ doCreateResetLink (Just userIdentifier) mCourseId = do
|
|||||||
|
|
||||||
addParticipant userId mCourseId
|
addParticipant userId mCourseId
|
||||||
|
|
||||||
key <- newToken
|
(key, expirationMoment) <- createLinkToken
|
||||||
theNow <- liftIO getCurrentTime
|
|
||||||
let expirationMoment = addUTCTime (60*60*24) theNow
|
|
||||||
runDB $ update userId [UserVerificationKey =. Just key, UserKeyExpirationDate =. Just expirationMoment]
|
runDB $ update userId [UserVerificationKey =. Just key, UserKeyExpirationDate =. Just expirationMoment]
|
||||||
|
|
||||||
defaultLayout $ do
|
defaultLayout $ do
|
||||||
|
162
Handler/Team.hs
162
Handler/Team.hs
@ -8,6 +8,7 @@ import Yesod.Form.Bootstrap3 (BootstrapFormLayout (..), renderBootstrap3, bfs)
|
|||||||
|
|
||||||
import Handler.Shared (fieldWithTooltip)
|
import Handler.Shared (fieldWithTooltip)
|
||||||
import Handler.JWT
|
import Handler.JWT
|
||||||
|
import Handler.AccountReset
|
||||||
|
|
||||||
import PersistTeamActionType
|
import PersistTeamActionType
|
||||||
|
|
||||||
@ -24,6 +25,8 @@ import Data.Proxy as DPR
|
|||||||
import Control.Lens hiding ((.=), (^.))
|
import Control.Lens hiding ((.=), (^.))
|
||||||
import Data.HashMap.Strict.InsOrd (fromList)
|
import Data.HashMap.Strict.InsOrd (fromList)
|
||||||
|
|
||||||
|
import qualified Data.Text as T
|
||||||
|
|
||||||
getMyTeamsR :: Handler Html
|
getMyTeamsR :: Handler Html
|
||||||
getMyTeamsR = do
|
getMyTeamsR = do
|
||||||
_ <- requireAuth
|
_ <- requireAuth
|
||||||
@ -60,21 +63,7 @@ createTeam userId teamCreationData = do
|
|||||||
teamIdent = theIdent,
|
teamIdent = theIdent,
|
||||||
teamAvatar = avatarBytes }
|
teamAvatar = avatarBytes }
|
||||||
|
|
||||||
_ <- insert TeamMember {
|
addMemberToTeam userId newTeamId True
|
||||||
teamMemberUser = userId,
|
|
||||||
teamMemberTeam = newTeamId,
|
|
||||||
teamMemberIsCaptain = True
|
|
||||||
}
|
|
||||||
|
|
||||||
theNow <- liftIO getCurrentTime
|
|
||||||
|
|
||||||
_ <- insert TeamLog {
|
|
||||||
teamLogStamp = theNow,
|
|
||||||
teamLogActionType = TeamCreation,
|
|
||||||
teamLogAgens = userId,
|
|
||||||
teamLogPatiens = Nothing,
|
|
||||||
teamLogVerificationKey = Nothing
|
|
||||||
}
|
|
||||||
|
|
||||||
return ()
|
return ()
|
||||||
|
|
||||||
@ -102,6 +91,7 @@ instance ToSchema TeamMemberView where
|
|||||||
& required .~ [ "name", "isCaptain" ]
|
& required .~ [ "name", "isCaptain" ]
|
||||||
|
|
||||||
data TeamView = TeamView {
|
data TeamView = TeamView {
|
||||||
|
teamViewId :: TeamId,
|
||||||
teamViewIdent :: Text,
|
teamViewIdent :: Text,
|
||||||
teamViewMembers :: [TeamMemberView]
|
teamViewMembers :: [TeamMemberView]
|
||||||
} deriving (Eq, Show)
|
} deriving (Eq, Show)
|
||||||
@ -124,9 +114,15 @@ instance ToSchema TeamView where
|
|||||||
]
|
]
|
||||||
& required .~ [ "ident", "members" ]
|
& 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 :: Handler Html
|
||||||
doMyTeams = do
|
doMyTeams = do
|
||||||
(formWidget, formEnctype) <- generateFormPost createTeamForm
|
(formWidget, formEnctype) <- generateFormPost createTeamForm
|
||||||
|
|
||||||
teams <- fetchMyTeams
|
teams <- fetchMyTeams
|
||||||
defaultLayout $ do
|
defaultLayout $ do
|
||||||
setTitle "Teams"
|
setTitle "Teams"
|
||||||
@ -160,9 +156,9 @@ fetchMyTeams :: Handler [TeamView]
|
|||||||
fetchMyTeams = do
|
fetchMyTeams = do
|
||||||
Entity userId _ <- requireAuthPossiblyByToken
|
Entity userId _ <- requireAuthPossiblyByToken
|
||||||
|
|
||||||
myTeams <- runDB $ E.select $ E.from $ \(team, member) -> do
|
myTeams <- runDB $ E.select $ E.from $ \(team, tmember) -> do
|
||||||
E.where_ (member ^. TeamMemberTeam E.==. team ^. TeamId
|
E.where_ (tmember ^. TeamMemberTeam E.==. team ^. TeamId
|
||||||
E.&&. member ^. TeamMemberUser E.==. E.val userId)
|
E.&&. tmember ^. TeamMemberUser E.==. E.val userId)
|
||||||
E.orderBy [E.asc (team ^. TeamIdent)]
|
E.orderBy [E.asc (team ^. TeamIdent)]
|
||||||
return team
|
return team
|
||||||
|
|
||||||
@ -173,13 +169,14 @@ fetchTeamInfo :: (YesodPersist site,
|
|||||||
PersistQueryRead (YesodPersistBackend site), PersistUniqueRead (YesodPersistBackend site))
|
PersistQueryRead (YesodPersistBackend site), PersistUniqueRead (YesodPersistBackend site))
|
||||||
=> Entity Team -> HandlerFor site TeamView
|
=> Entity Team -> HandlerFor site TeamView
|
||||||
fetchTeamInfo (Entity teamId team) = do
|
fetchTeamInfo (Entity teamId team) = do
|
||||||
members <- runDB $ E.select $ E.from $ \(user, member) -> do
|
members <- runDB $ E.select $ E.from $ \(user, tmember) -> do
|
||||||
E.where_ (member ^. TeamMemberTeam E.==. E.val teamId
|
E.where_ (tmember ^. TeamMemberTeam E.==. E.val teamId
|
||||||
E.&&. member ^. TeamMemberUser E.==. user ^. UserId)
|
E.&&. tmember ^. TeamMemberUser E.==. user ^. UserId)
|
||||||
E.orderBy [E.asc (user ^. UserIdent)]
|
E.orderBy [E.asc (user ^. UserIdent)]
|
||||||
return (user, member)
|
return (user, tmember)
|
||||||
|
|
||||||
return $ TeamView {
|
return $ TeamView {
|
||||||
|
teamViewId = teamId,
|
||||||
teamViewIdent = teamIdent team,
|
teamViewIdent = teamIdent team,
|
||||||
teamViewMembers = map (\(u, m) -> TeamMemberView {
|
teamViewMembers = map (\(u, m) -> TeamMemberView {
|
||||||
teamMemberViewName = userIdent $ entityVal u,
|
teamMemberViewName = userIdent $ entityVal u,
|
||||||
@ -191,3 +188,124 @@ createTeamForm :: Form TeamCreationData
|
|||||||
createTeamForm = renderBootstrap3 BootstrapBasicForm $ TeamCreationData
|
createTeamForm = renderBootstrap3 BootstrapBasicForm $ TeamCreationData
|
||||||
<$> areq textField (fieldWithTooltip MsgTeamIdent MsgTeamIdentTooltip) Nothing
|
<$> areq textField (fieldWithTooltip MsgTeamIdent MsgTeamIdentTooltip) Nothing
|
||||||
<*> fileAFormOpt (bfs MsgAvatar)
|
<*> 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
|
||||||
|
@ -5,7 +5,7 @@ import Database.Persist.Sql
|
|||||||
|
|
||||||
import qualified Data.Text as T
|
import qualified Data.Text as T
|
||||||
|
|
||||||
data TeamActionType = TeamCreation | TeamJoining | TeamLeaving
|
data TeamActionType = TeamCreation | TeamJoining | TeamLeaving | TeamInvitation
|
||||||
deriving (Eq, Show, Read)
|
deriving (Eq, Show, Read)
|
||||||
|
|
||||||
instance PersistField TeamActionType where
|
instance PersistField TeamActionType where
|
||||||
|
@ -25,7 +25,9 @@ TeamLog
|
|||||||
actionType TeamActionType
|
actionType TeamActionType
|
||||||
agens UserId
|
agens UserId
|
||||||
patiens UserId Maybe
|
patiens UserId Maybe
|
||||||
|
team TeamId Maybe
|
||||||
verificationKey Text Maybe
|
verificationKey Text Maybe
|
||||||
|
keyExpirationDate UTCTime Maybe
|
||||||
PublicKey
|
PublicKey
|
||||||
user UserId
|
user UserId
|
||||||
pubkey Text
|
pubkey Text
|
||||||
|
@ -31,6 +31,8 @@
|
|||||||
|
|
||||||
/my-teams MyTeamsR GET
|
/my-teams MyTeamsR GET
|
||||||
/create-team CreateTeamR POST
|
/create-team CreateTeamR POST
|
||||||
|
/create-team-invitation-link CreateTeamInvitationLinkR POST
|
||||||
|
/invitation-link/#Text TeamInvitationLinkR GET POST
|
||||||
|
|
||||||
/challenge/#Text ShowChallengeR GET
|
/challenge/#Text ShowChallengeR GET
|
||||||
/challenge-readme/#Text ChallengeReadmeR GET
|
/challenge-readme/#Text ChallengeReadmeR GET
|
||||||
|
@ -103,3 +103,5 @@ TeamIdent: Team name
|
|||||||
TeamIdentTooltip: Note that it cannot be changed later
|
TeamIdentTooltip: Note that it cannot be changed later
|
||||||
YourTeams: your teams
|
YourTeams: your teams
|
||||||
AsTeam: As team
|
AsTeam: As team
|
||||||
|
InviteToTeam: Invite to team (give the identifier/login of a user)
|
||||||
|
Join: Join
|
||||||
|
4
templates/invitation-link-created.hamlet
Normal file
4
templates/invitation-link-created.hamlet
Normal file
@ -0,0 +1,4 @@
|
|||||||
|
<p>Send this link to #{ident}
|
||||||
|
|
||||||
|
<p>
|
||||||
|
<a href=@{TeamInvitationLinkR token}>@{TeamInvitationLinkR token}
|
@ -7,6 +7,8 @@ $forall team <- teams
|
|||||||
<ul>
|
<ul>
|
||||||
<li>#{teamMemberViewName member}
|
<li>#{teamMemberViewName member}
|
||||||
|
|
||||||
|
^{invitation $ teamViewId team}
|
||||||
|
|
||||||
<hr>
|
<hr>
|
||||||
|
|
||||||
<h2>Create a new team
|
<h2>Create a new team
|
||||||
|
4
templates/receive-invitation-link.hamlet
Normal file
4
templates/receive-invitation-link.hamlet
Normal file
@ -0,0 +1,4 @@
|
|||||||
|
<p>You are invited by #{userIdent $ entityVal inviter} to join the team #{teamIdent $ entityVal team}.
|
||||||
|
|
||||||
|
<form method=post action=@{TeamInvitationLinkR key}#form enctype="text/plain">
|
||||||
|
<button>_{MsgJoin}
|
4
templates/team-invitation-form.hamlet
Normal file
4
templates/team-invitation-form.hamlet
Normal file
@ -0,0 +1,4 @@
|
|||||||
|
<form method=post action=@{CreateTeamInvitationLinkR}#form enctype=#{formEnctype}>
|
||||||
|
^{formWidget}
|
||||||
|
<button .btn .btn-primary type="submit">
|
||||||
|
_{MsgSubmit} <span class="glyphicon glyphicon-upload"></span>
|
4
templates/team-invitation.hamlet
Normal file
4
templates/team-invitation.hamlet
Normal file
@ -0,0 +1,4 @@
|
|||||||
|
<form method=post action=@{CreateTeamInvitationLinkR}#form enctype=#{invitationFormEnctype}>
|
||||||
|
^{invitationFormWidget}
|
||||||
|
<button .btn .btn-primary type="submit">
|
||||||
|
_{MsgSubmit} <span class="glyphicon glyphicon-upload"></span>
|
Loading…
Reference in New Issue
Block a user