Get info on user teams

This commit is contained in:
Filip Gralinski 2021-03-11 22:27:22 +01:00
parent 341d912ba8
commit 29ee5ad6ac
4 changed files with 127 additions and 1 deletions

View File

@ -7,6 +7,7 @@ import Handler.ListChallenges
import Handler.ShowChallenge import Handler.ShowChallenge
import Handler.Query import Handler.Query
import Handler.Tags import Handler.Tags
import Handler.Team
import Control.Lens hiding ((.=)) import Control.Lens hiding ((.=))
@ -25,6 +26,7 @@ apiDescription = generalApi
<> challengeSubmissionApi <> challengeSubmissionApi
<> versionInfoApi <> versionInfoApi
<> listTagsApi <> listTagsApi
<> myTeamsApi
generalApi :: Swagger generalApi :: Swagger
generalApi = (mempty :: Swagger) generalApi = (mempty :: Swagger)

View File

@ -1,10 +1,13 @@
{-# LANGUAGE OverloadedLists #-}
module Handler.Team where module Handler.Team where
import Import import Import hiding (fromList)
import Yesod.Form.Bootstrap3 (BootstrapFormLayout (..), renderBootstrap3, bfs) import Yesod.Form.Bootstrap3 (BootstrapFormLayout (..), renderBootstrap3, bfs)
import Handler.Shared (fieldWithTooltip) import Handler.Shared (fieldWithTooltip)
import Handler.JWT
import PersistTeamActionType import PersistTeamActionType
@ -12,6 +15,15 @@ import Data.Conduit.Binary
import qualified Data.ByteString as S import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L 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)
getMyTeamsR :: Handler Html getMyTeamsR :: Handler Html
getMyTeamsR = do getMyTeamsR = do
_ <- requireAuth _ <- requireAuth
@ -66,13 +78,115 @@ createTeam userId teamCreationData = do
return () 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 {
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" ]
doMyTeams :: Handler Html doMyTeams :: Handler Html
doMyTeams = do doMyTeams = do
(formWidget, formEnctype) <- generateFormPost createTeamForm (formWidget, formEnctype) <- generateFormPost createTeamForm
teams <- fetchMyTeams
defaultLayout $ do defaultLayout $ do
setTitle "Teams" setTitle "Teams"
$(widgetFile "my-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, member) -> do
E.where_ (member ^. TeamMemberTeam E.==. team ^. TeamId
E.&&. member ^. 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, member) -> do
E.where_ (member ^. TeamMemberTeam E.==. E.val teamId
E.&&. member ^. TeamMemberUser E.==. user ^. UserId)
E.orderBy [E.asc (user ^. UserIdent)]
return (user, member)
return $ TeamView {
teamViewIdent = teamIdent team,
teamViewMembers = map (\(u, m) -> TeamMemberView {
teamMemberViewName = userIdent $ entityVal u,
teamMemberViewIsCaptain = teamMemberIsCaptain $ entityVal m}) members }
createTeamForm :: Form TeamCreationData createTeamForm :: Form TeamCreationData
createTeamForm = renderBootstrap3 BootstrapBasicForm $ TeamCreationData createTeamForm = renderBootstrap3 BootstrapBasicForm $ TeamCreationData
<$> areq textField (fieldWithTooltip MsgTeamIdent MsgTeamIdentTooltip) Nothing <$> areq textField (fieldWithTooltip MsgTeamIdent MsgTeamIdentTooltip) Nothing

View File

@ -26,6 +26,7 @@
/api/challenge-info/#Text ChallengeInfoJsonR GET /api/challenge-info/#Text ChallengeInfoJsonR GET
/api/version-info/#Text VersionInfoJsonR GET /api/version-info/#Text VersionInfoJsonR GET
/api/list-tags ListTagsJsonR GET /api/list-tags ListTagsJsonR GET
/api/my-teams MyTeamsJsonR GET
/list-archived-challenges ListArchivedChallengesR GET /list-archived-challenges ListArchivedChallengesR GET
/my-teams MyTeamsR GET /my-teams MyTeamsR GET

View File

@ -1,3 +1,12 @@
<h2>Your teams
$forall team <- teams
<h3>#{teamViewIdent team}
$forall member <- teamViewMembers team
<ul>
<li>#{teamMemberViewName member}
<hr> <hr>
<h2>Create a new team <h2>Create a new team