forked from filipg/gonito
Get info on user teams
This commit is contained in:
parent
341d912ba8
commit
29ee5ad6ac
@ -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)
|
||||||
|
116
Handler/Team.hs
116
Handler/Team.hs
@ -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
|
||||||
|
@ -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
|
||||||
|
@ -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
|
||||||
|
Loading…
Reference in New Issue
Block a user