diff --git a/Handler/Swagger.hs b/Handler/Swagger.hs index 2e98012..94ae5ba 100644 --- a/Handler/Swagger.hs +++ b/Handler/Swagger.hs @@ -7,6 +7,7 @@ import Handler.ListChallenges import Handler.ShowChallenge import Handler.Query import Handler.Tags +import Handler.Team import Control.Lens hiding ((.=)) @@ -25,6 +26,7 @@ apiDescription = generalApi <> challengeSubmissionApi <> versionInfoApi <> listTagsApi + <> myTeamsApi generalApi :: Swagger generalApi = (mempty :: Swagger) diff --git a/Handler/Team.hs b/Handler/Team.hs index 106731c..75b86af 100644 --- a/Handler/Team.hs +++ b/Handler/Team.hs @@ -1,10 +1,13 @@ +{-# LANGUAGE OverloadedLists #-} + module Handler.Team where -import Import +import Import hiding (fromList) import Yesod.Form.Bootstrap3 (BootstrapFormLayout (..), renderBootstrap3, bfs) import Handler.Shared (fieldWithTooltip) +import Handler.JWT import PersistTeamActionType @@ -12,6 +15,15 @@ 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) + getMyTeamsR :: Handler Html getMyTeamsR = do _ <- requireAuth @@ -66,13 +78,115 @@ createTeam userId teamCreationData = do 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 = 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, 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 = renderBootstrap3 BootstrapBasicForm $ TeamCreationData <$> areq textField (fieldWithTooltip MsgTeamIdent MsgTeamIdentTooltip) Nothing diff --git a/config/routes b/config/routes index f6fb0f0..c2054c2 100644 --- a/config/routes +++ b/config/routes @@ -26,6 +26,7 @@ /api/challenge-info/#Text ChallengeInfoJsonR GET /api/version-info/#Text VersionInfoJsonR GET /api/list-tags ListTagsJsonR GET +/api/my-teams MyTeamsJsonR GET /list-archived-challenges ListArchivedChallengesR GET /my-teams MyTeamsR GET diff --git a/templates/my-teams.hamlet b/templates/my-teams.hamlet index 5ccbb94..e7c00c6 100644 --- a/templates/my-teams.hamlet +++ b/templates/my-teams.hamlet @@ -1,3 +1,12 @@ + +

Your teams + +$forall team <- teams +

#{teamViewIdent team} + $forall member <- teamViewMembers team +