forked from filipg/gonito
312 lines
10 KiB
Haskell
312 lines
10 KiB
Haskell
{-# LANGUAGE OverloadedLists #-}
|
|
|
|
module Handler.Team where
|
|
|
|
import Import hiding (fromList)
|
|
|
|
import Yesod.Form.Bootstrap3 (BootstrapFormLayout (..), renderBootstrap3, bfs)
|
|
|
|
import Handler.Shared (fieldWithTooltip)
|
|
import Handler.JWT
|
|
import Handler.AccountReset
|
|
|
|
import PersistTeamActionType
|
|
|
|
import Data.Conduit.Binary
|
|
import qualified Data.ByteString as S
|
|
import qualified Data.ByteString.Lazy as L
|
|
|
|
import qualified Database.Esqueleto as E
|
|
import Database.Esqueleto ((^.))
|
|
|
|
import Data.Swagger.Declare
|
|
import Data.Swagger hiding (Tag, tags)
|
|
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
|
|
doMyTeams
|
|
|
|
data TeamCreationData = TeamCreationData {
|
|
teamCreationTeamIdent :: Text,
|
|
teamCreationTeamAvatar :: Maybe FileInfo }
|
|
|
|
postCreateTeamR :: Handler Html
|
|
postCreateTeamR = do
|
|
Entity userId _ <- requireAuth
|
|
((result, _), _) <- runFormPost createTeamForm
|
|
case result of
|
|
FormSuccess teamCreationData -> do
|
|
runDB $ createTeam userId teamCreationData
|
|
_ -> do
|
|
return ()
|
|
doMyTeams
|
|
|
|
createTeam :: (PersistStoreWrite backend, MonadUnliftIO m, BaseBackend backend ~ SqlBackend)
|
|
=> Key User -> TeamCreationData -> ReaderT backend m ()
|
|
createTeam userId teamCreationData = do
|
|
let theIdent = teamCreationTeamIdent teamCreationData
|
|
let theAvatar = teamCreationTeamAvatar teamCreationData
|
|
|
|
avatarBytes <- case theAvatar of
|
|
Just avatarFile -> do
|
|
fileBytes <- runResourceT $ fileSource avatarFile $$ sinkLbs
|
|
return $ Just (S.pack . L.unpack $ fileBytes)
|
|
Nothing -> return Nothing
|
|
|
|
newTeamId <- insert Team {
|
|
teamIdent = theIdent,
|
|
teamAvatar = avatarBytes }
|
|
|
|
addMemberToTeam userId newTeamId True
|
|
|
|
return ()
|
|
|
|
data TeamMemberView = TeamMemberView {
|
|
teamMemberViewName :: Text,
|
|
teamMemberViewIsCaptain :: Bool
|
|
} deriving (Eq, Show)
|
|
|
|
instance ToJSON TeamMemberView where
|
|
toJSON v = object
|
|
[ "name" .= (teamMemberViewName v)
|
|
, "isCaptain" .= (teamMemberViewIsCaptain v)
|
|
]
|
|
|
|
instance ToSchema TeamMemberView where
|
|
declareNamedSchema _ = do
|
|
stringSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy String)
|
|
boolSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy Bool)
|
|
return $ NamedSchema (Just "TeamMember") $ mempty
|
|
& type_ .~ SwaggerObject
|
|
& properties .~
|
|
fromList [ ("name", stringSchema)
|
|
, ("isCaptain", boolSchema)
|
|
]
|
|
& required .~ [ "name", "isCaptain" ]
|
|
|
|
data TeamView = TeamView {
|
|
teamViewId :: TeamId,
|
|
teamViewIdent :: Text,
|
|
teamViewMembers :: [TeamMemberView]
|
|
} deriving (Eq, Show)
|
|
|
|
instance ToJSON TeamView where
|
|
toJSON v = object
|
|
[ "ident" .= (teamViewIdent v)
|
|
, "members" .= (teamViewMembers v)
|
|
]
|
|
|
|
instance ToSchema TeamView where
|
|
declareNamedSchema _ = do
|
|
stringSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy String)
|
|
membersSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy [TeamMemberView])
|
|
return $ NamedSchema (Just "Team") $ mempty
|
|
& type_ .~ SwaggerObject
|
|
& properties .~
|
|
fromList [ ("ident", stringSchema)
|
|
, ("members", membersSchema)
|
|
]
|
|
& 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"
|
|
$(widgetFile "my-teams")
|
|
|
|
myTeamsApi :: Swagger
|
|
myTeamsApi = spec & definitions .~ defs
|
|
where
|
|
(defs, spec) = runDeclare declareMyTeamsSwagger mempty
|
|
|
|
declareMyTeamsSwagger :: Declare (Definitions Schema) Swagger
|
|
declareMyTeamsSwagger = do
|
|
myTeamsResponse <- declareResponse (DPR.Proxy :: DPR.Proxy [TeamView])
|
|
|
|
return $ mempty
|
|
& paths .~
|
|
[ ("/api/my-teams", mempty & Data.Swagger.get ?~ (mempty
|
|
& produces ?~ MimeList ["application/json"]
|
|
& description ?~ "Returns the list of teams the user belongs to"
|
|
& at 200 ?~ Inline myTeamsResponse))
|
|
]
|
|
|
|
|
|
getMyTeamsJsonR :: Handler Value
|
|
getMyTeamsJsonR = do
|
|
teams <- fetchMyTeams
|
|
return $ toJSON teams
|
|
|
|
|
|
fetchMyTeams :: Handler [TeamView]
|
|
fetchMyTeams = do
|
|
Entity userId _ <- requireAuthPossiblyByToken
|
|
|
|
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
|
|
|
|
mapM fetchTeamInfo myTeams
|
|
|
|
fetchTeamInfo :: (YesodPersist site,
|
|
BackendCompatible SqlBackend (YesodPersistBackend site),
|
|
PersistQueryRead (YesodPersistBackend site), PersistUniqueRead (YesodPersistBackend site))
|
|
=> Entity Team -> HandlerFor site TeamView
|
|
fetchTeamInfo (Entity teamId team) = do
|
|
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, tmember)
|
|
|
|
return $ TeamView {
|
|
teamViewId = teamId,
|
|
teamViewIdent = teamIdent team,
|
|
teamViewMembers = map (\(u, m) -> TeamMemberView {
|
|
teamMemberViewName = userIdent $ entityVal u,
|
|
teamMemberViewIsCaptain = teamMemberIsCaptain $ entityVal m}) members }
|
|
|
|
|
|
|
|
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
|