gonito/Handler/Team.hs

194 lines
6.1 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 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)
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 }
_ <- insert TeamMember {
teamMemberUser = userId,
teamMemberTeam = newTeamId,
teamMemberIsCaptain = True
}
theNow <- liftIO getCurrentTime
_ <- insert TeamLog {
teamLogStamp = theNow,
teamLogActionType = TeamCreation,
teamLogAgens = userId,
teamLogPatiens = Nothing,
teamLogVerificationKey = Nothing
}
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
<*> fileAFormOpt (bfs MsgAvatar)