Get info on user teams

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)

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

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

templates/my-teams.hamlet

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