Client, UI: Team: Creation, invite/join display, list in personal overview
This commit is contained in:
parent
8584c6387c
commit
7517db9619
13 changed files with 166 additions and 75 deletions
|
@ -211,7 +211,7 @@ clientAdd now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHosts a
|
||||||
manager <- asksEnv envHttpManager
|
manager <- asksEnv envHttpManager
|
||||||
coll <- ExceptT $ liftIO $ first T.pack <$> AP.fetchAPID manager AP.collectionId h luComps
|
coll <- ExceptT $ liftIO $ first T.pack <$> AP.fetchAPID manager AP.collectionId h luComps
|
||||||
lu <- fromMaybeE (AP.collectionContext (coll :: AP.Collection FedURI URIMode)) "Remote topic collabs has no 'context'"
|
lu <- fromMaybeE (AP.collectionContext (coll :: AP.Collection FedURI URIMode)) "Remote topic collabs has no 'context'"
|
||||||
AP.ResourceWithCollections _ _ mluComps <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
|
AP.ResourceWithCollections _ _ mluComps _ <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
|
||||||
unless (mluComps == Just luComps) $
|
unless (mluComps == Just luComps) $
|
||||||
throwE "Add target isn't a components list"
|
throwE "Add target isn't a components list"
|
||||||
|
|
||||||
|
@ -845,8 +845,8 @@ clientInvite now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost
|
||||||
manager <- asksEnv envHttpManager
|
manager <- asksEnv envHttpManager
|
||||||
coll <- ExceptT $ liftIO $ first T.pack <$> AP.fetchAPID manager AP.collectionId h luColl
|
coll <- ExceptT $ liftIO $ first T.pack <$> AP.fetchAPID manager AP.collectionId h luColl
|
||||||
lu <- fromMaybeE (AP.collectionContext (coll :: AP.Collection FedURI URIMode)) "Remote topic collabs has no 'context'"
|
lu <- fromMaybeE (AP.collectionContext (coll :: AP.Collection FedURI URIMode)) "Remote topic collabs has no 'context'"
|
||||||
AP.ResourceWithCollections _ mluCollabs mluComps <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
|
AP.ResourceWithCollections _ mluCollabs mluComps mluMembers <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
|
||||||
unless (mluCollabs == Just luColl || mluComps == Just luColl) $
|
unless (mluCollabs == Just luColl || mluComps == Just luColl || mluMembers == Just luColl) $
|
||||||
throwE "Invite target isn't a collabs/components list"
|
throwE "Invite target isn't a collabs/components list"
|
||||||
|
|
||||||
instanceID <-
|
instanceID <-
|
||||||
|
@ -1079,8 +1079,8 @@ clientRemove now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost
|
||||||
manager <- asksEnv envHttpManager
|
manager <- asksEnv envHttpManager
|
||||||
coll <- ExceptT $ liftIO $ first T.pack <$> AP.fetchAPID manager AP.collectionId h luColl
|
coll <- ExceptT $ liftIO $ first T.pack <$> AP.fetchAPID manager AP.collectionId h luColl
|
||||||
lu <- fromMaybeE (AP.collectionContext (coll :: AP.Collection FedURI URIMode)) "Remote topic collabs has no 'context'"
|
lu <- fromMaybeE (AP.collectionContext (coll :: AP.Collection FedURI URIMode)) "Remote topic collabs has no 'context'"
|
||||||
AP.ResourceWithCollections _ mluCollabs _ <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
|
AP.ResourceWithCollections _ mluCollabs _ mluMembers <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
|
||||||
unless (mluCollabs == Just luColl) $
|
unless (mluCollabs == Just luColl || mluMembers == Just luColl) $
|
||||||
throwE "Remove origin isn't a collabs list"
|
throwE "Remove origin isn't a collabs list"
|
||||||
return $ ObjURI h lu
|
return $ ObjURI h lu
|
||||||
)
|
)
|
||||||
|
|
|
@ -38,6 +38,7 @@ module Vervis.Client
|
||||||
, createLoom
|
, createLoom
|
||||||
, createRepo
|
, createRepo
|
||||||
, createProject
|
, createProject
|
||||||
|
, createGroup
|
||||||
, invite
|
, invite
|
||||||
, remove
|
, remove
|
||||||
, inviteComponent
|
, inviteComponent
|
||||||
|
@ -1050,6 +1051,27 @@ createProject senderHash name desc = do
|
||||||
|
|
||||||
return (Nothing, audience, detail)
|
return (Nothing, audience, detail)
|
||||||
|
|
||||||
|
createGroup
|
||||||
|
:: (MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App)
|
||||||
|
=> KeyHashid Person
|
||||||
|
-> Text
|
||||||
|
-> Text
|
||||||
|
-> m (Maybe HTML, [Aud URIMode], AP.ActorDetail)
|
||||||
|
createGroup senderHash name desc = do
|
||||||
|
let audAuthor =
|
||||||
|
AudLocal [] [LocalStagePersonFollowers senderHash]
|
||||||
|
|
||||||
|
audience = [audAuthor]
|
||||||
|
|
||||||
|
detail = AP.ActorDetail
|
||||||
|
{ AP.actorType = AP.ActorTypeTeam
|
||||||
|
, AP.actorUsername = Nothing
|
||||||
|
, AP.actorName = Just name
|
||||||
|
, AP.actorSummary = Just desc
|
||||||
|
}
|
||||||
|
|
||||||
|
return (Nothing, audience, detail)
|
||||||
|
|
||||||
invite
|
invite
|
||||||
:: PersonId
|
:: PersonId
|
||||||
-> FedURI
|
-> FedURI
|
||||||
|
@ -1090,8 +1112,8 @@ invite personID uRecipient uResourceCollabs role = do
|
||||||
manager <- asksSite appHttpManager
|
manager <- asksSite appHttpManager
|
||||||
coll <- ExceptT $ liftIO $ first T.pack <$> AP.fetchAPID manager AP.collectionId h luColl
|
coll <- ExceptT $ liftIO $ first T.pack <$> AP.fetchAPID manager AP.collectionId h luColl
|
||||||
lu <- fromMaybeE (AP.collectionContext (coll :: AP.Collection FedURI URIMode)) "Remote topic collabs has no 'context'"
|
lu <- fromMaybeE (AP.collectionContext (coll :: AP.Collection FedURI URIMode)) "Remote topic collabs has no 'context'"
|
||||||
AP.ResourceWithCollections _ mluCollabs _ <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
|
AP.ResourceWithCollections _ mluCollabs _ mluMembers <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
|
||||||
unless (mluCollabs == Just luColl) $
|
unless (mluCollabs == Just luColl || mluMembers == Just luColl) $
|
||||||
throwE "Invite target isn't a collabs list"
|
throwE "Invite target isn't a collabs list"
|
||||||
return $ ObjURI h lu
|
return $ ObjURI h lu
|
||||||
)
|
)
|
||||||
|
@ -1204,8 +1226,8 @@ remove personID uRecipient uResourceCollabs = do
|
||||||
manager <- asksSite appHttpManager
|
manager <- asksSite appHttpManager
|
||||||
coll <- ExceptT $ liftIO $ first T.pack <$> AP.fetchAPID manager AP.collectionId h luColl
|
coll <- ExceptT $ liftIO $ first T.pack <$> AP.fetchAPID manager AP.collectionId h luColl
|
||||||
lu <- fromMaybeE (AP.collectionContext (coll :: AP.Collection FedURI URIMode)) "Remote topic collabs has no 'context'"
|
lu <- fromMaybeE (AP.collectionContext (coll :: AP.Collection FedURI URIMode)) "Remote topic collabs has no 'context'"
|
||||||
AP.ResourceWithCollections _ mluCollabs _ <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
|
AP.ResourceWithCollections _ mluCollabs _ mluMembers <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
|
||||||
unless (mluCollabs == Just luColl) $
|
unless (mluCollabs == Just luColl || mluMembers == Just luColl) $
|
||||||
throwE "Remove origin isn't a collabs list"
|
throwE "Remove origin isn't a collabs list"
|
||||||
return $ ObjURI h lu
|
return $ ObjURI h lu
|
||||||
)
|
)
|
||||||
|
|
|
@ -100,12 +100,14 @@ parseGrantResource (RepoR r) = Just $ GrantResourceRepo r
|
||||||
parseGrantResource (DeckR d) = Just $ GrantResourceDeck d
|
parseGrantResource (DeckR d) = Just $ GrantResourceDeck d
|
||||||
parseGrantResource (LoomR l) = Just $ GrantResourceLoom l
|
parseGrantResource (LoomR l) = Just $ GrantResourceLoom l
|
||||||
parseGrantResource (ProjectR l) = Just $ GrantResourceProject l
|
parseGrantResource (ProjectR l) = Just $ GrantResourceProject l
|
||||||
|
parseGrantResource (GroupR l) = Just $ GrantResourceGroup l
|
||||||
parseGrantResource _ = Nothing
|
parseGrantResource _ = Nothing
|
||||||
|
|
||||||
parseGrantResourceCollabs (RepoCollabsR r) = Just $ GrantResourceRepo r
|
parseGrantResourceCollabs (RepoCollabsR r) = Just $ GrantResourceRepo r
|
||||||
parseGrantResourceCollabs (DeckCollabsR d) = Just $ GrantResourceDeck d
|
parseGrantResourceCollabs (DeckCollabsR d) = Just $ GrantResourceDeck d
|
||||||
parseGrantResourceCollabs (LoomCollabsR l) = Just $ GrantResourceLoom l
|
parseGrantResourceCollabs (LoomCollabsR l) = Just $ GrantResourceLoom l
|
||||||
parseGrantResourceCollabs (ProjectCollabsR l) = Just $ GrantResourceProject l
|
parseGrantResourceCollabs (ProjectCollabsR l) = Just $ GrantResourceProject l
|
||||||
|
parseGrantResourceCollabs (GroupMembersR l) = Just $ GrantResourceGroup l
|
||||||
parseGrantResourceCollabs _ = Nothing
|
parseGrantResourceCollabs _ = Nothing
|
||||||
|
|
||||||
data GrantRecipBy f = GrantRecipPerson (f Person)
|
data GrantRecipBy f = GrantRecipPerson (f Person)
|
||||||
|
|
|
@ -18,6 +18,8 @@ module Vervis.Form.Tracker
|
||||||
, newDeckForm
|
, newDeckForm
|
||||||
, NewProject (..)
|
, NewProject (..)
|
||||||
, newProjectForm
|
, newProjectForm
|
||||||
|
, NewGroup (..)
|
||||||
|
, newGroupForm
|
||||||
, NewLoom (..)
|
, NewLoom (..)
|
||||||
, newLoomForm
|
, newLoomForm
|
||||||
, DeckInvite (..)
|
, DeckInvite (..)
|
||||||
|
@ -73,6 +75,16 @@ newProjectForm = renderDivs $ NewProject
|
||||||
<$> areq textField "Name*" Nothing
|
<$> areq textField "Name*" Nothing
|
||||||
<*> areq textField "Description" Nothing
|
<*> areq textField "Description" Nothing
|
||||||
|
|
||||||
|
data NewGroup = NewGroup
|
||||||
|
{ ngName :: Text
|
||||||
|
, ngDesc :: Text
|
||||||
|
}
|
||||||
|
|
||||||
|
newGroupForm :: Form NewGroup
|
||||||
|
newGroupForm = renderDivs $ NewGroup
|
||||||
|
<$> areq textField "Name*" Nothing
|
||||||
|
<*> areq textField "Description" Nothing
|
||||||
|
|
||||||
data NewLoom = NewLoom
|
data NewLoom = NewLoom
|
||||||
{ nlName :: Text
|
{ nlName :: Text
|
||||||
, nlDesc :: Text
|
, nlDesc :: Text
|
||||||
|
|
|
@ -872,6 +872,7 @@ instance YesodBreadcrumbs App where
|
||||||
|
|
||||||
PersonStampR p k -> ("Stamp #" <> keyHashidText k, Just $ PersonR p)
|
PersonStampR p k -> ("Stamp #" <> keyHashidText k, Just $ PersonR p)
|
||||||
|
|
||||||
|
GroupNewR -> ("New Team", Just HomeR)
|
||||||
GroupR g -> ("Team &" <> keyHashidText g, Just HomeR)
|
GroupR g -> ("Team &" <> keyHashidText g, Just HomeR)
|
||||||
GroupInboxR g -> ("Inbox", Just $ GroupR g)
|
GroupInboxR g -> ("Inbox", Just $ GroupR g)
|
||||||
GroupOutboxR g -> ("Outbox", Just $ GroupR g)
|
GroupOutboxR g -> ("Outbox", Just $ GroupR g)
|
||||||
|
|
|
@ -130,7 +130,7 @@ getHomeR = do
|
||||||
where
|
where
|
||||||
personalOverview :: Entity Person -> Handler Html
|
personalOverview :: Entity Person -> Handler Html
|
||||||
personalOverview (Entity pid _person) = do
|
personalOverview (Entity pid _person) = do
|
||||||
(repos, decks, looms, projects) <- runDB $ (,,,)
|
(repos, decks, looms, projects, groups) <- runDB $ (,,,,)
|
||||||
<$> (E.select $ E.from $ \ (recip `E.InnerJoin` collab `E.InnerJoin` topic `E.InnerJoin` enable `E.InnerJoin` repo `E.InnerJoin` actor) -> do
|
<$> (E.select $ E.from $ \ (recip `E.InnerJoin` collab `E.InnerJoin` topic `E.InnerJoin` enable `E.InnerJoin` repo `E.InnerJoin` actor) -> do
|
||||||
E.on $ repo E.^. RepoActor E.==. actor E.^. ActorId
|
E.on $ repo E.^. RepoActor E.==. actor E.^. ActorId
|
||||||
E.on $ topic E.^. CollabTopicRepoRepo E.==. repo E.^. RepoId
|
E.on $ topic E.^. CollabTopicRepoRepo E.==. repo E.^. RepoId
|
||||||
|
@ -171,10 +171,21 @@ getHomeR = do
|
||||||
E.orderBy [E.asc $ project E.^. ProjectId]
|
E.orderBy [E.asc $ project E.^. ProjectId]
|
||||||
return (project, actor, collab)
|
return (project, actor, collab)
|
||||||
)
|
)
|
||||||
|
<*> (E.select $ E.from $ \ (recip `E.InnerJoin` collab `E.InnerJoin` topic `E.InnerJoin` enable `E.InnerJoin` group `E.InnerJoin` actor) -> do
|
||||||
|
E.on $ group E.^. GroupActor E.==. actor E.^. ActorId
|
||||||
|
E.on $ topic E.^. CollabTopicGroupGroup E.==. group E.^. GroupId
|
||||||
|
E.on $ topic E.^. CollabTopicGroupCollab E.==. enable E.^. CollabEnableCollab
|
||||||
|
E.on $ recip E.^. CollabRecipLocalCollab E.==. topic E.^. CollabTopicGroupCollab
|
||||||
|
E.on $ recip E.^. CollabRecipLocalCollab E.==. collab E.^. CollabId
|
||||||
|
E.where_ $ recip E.^. CollabRecipLocalPerson E.==. E.val pid
|
||||||
|
E.orderBy [E.asc $ group E.^. GroupId]
|
||||||
|
return (group, actor, collab)
|
||||||
|
)
|
||||||
hashRepo <- getEncodeKeyHashid
|
hashRepo <- getEncodeKeyHashid
|
||||||
hashDeck <- getEncodeKeyHashid
|
hashDeck <- getEncodeKeyHashid
|
||||||
hashLoom <- getEncodeKeyHashid
|
hashLoom <- getEncodeKeyHashid
|
||||||
hashProject <- getEncodeKeyHashid
|
hashProject <- getEncodeKeyHashid
|
||||||
|
hashGroup <- getEncodeKeyHashid
|
||||||
defaultLayout $(widgetFile "personal-overview")
|
defaultLayout $(widgetFile "personal-overview")
|
||||||
|
|
||||||
getBrowseR :: Handler Html
|
getBrowseR :: Handler Html
|
||||||
|
|
|
@ -14,7 +14,10 @@
|
||||||
-}
|
-}
|
||||||
|
|
||||||
module Vervis.Handler.Group
|
module Vervis.Handler.Group
|
||||||
( getGroupR
|
( getGroupNewR
|
||||||
|
, postGroupNewR
|
||||||
|
|
||||||
|
, getGroupR
|
||||||
, getGroupInboxR
|
, getGroupInboxR
|
||||||
, postGroupInboxR
|
, postGroupInboxR
|
||||||
, getGroupOutboxR
|
, getGroupOutboxR
|
||||||
|
@ -33,8 +36,6 @@ module Vervis.Handler.Group
|
||||||
|
|
||||||
{-
|
{-
|
||||||
, getGroupsR
|
, getGroupsR
|
||||||
, postGroupsR
|
|
||||||
, getGroupNewR
|
|
||||||
, postGroupMembersR
|
, postGroupMembersR
|
||||||
, getGroupMemberNewR
|
, getGroupMemberNewR
|
||||||
, getGroupMemberR
|
, getGroupMemberR
|
||||||
|
@ -118,6 +119,37 @@ import Vervis.Widget.Tracker
|
||||||
|
|
||||||
import qualified Vervis.Client as C
|
import qualified Vervis.Client as C
|
||||||
|
|
||||||
|
getGroupNewR :: Handler Html
|
||||||
|
getGroupNewR = do
|
||||||
|
((_result, widget), enctype) <- runFormPost newGroupForm
|
||||||
|
defaultLayout $(widgetFile "group/new")
|
||||||
|
|
||||||
|
postGroupNewR :: Handler Html
|
||||||
|
postGroupNewR = do
|
||||||
|
NewGroup name desc <- runFormPostRedirect GroupNewR newGroupForm
|
||||||
|
|
||||||
|
personEntity@(Entity personID person) <- requireAuth
|
||||||
|
personHash <- encodeKeyHashid personID
|
||||||
|
(maybeSummary, audience, detail) <- C.createGroup personHash name desc
|
||||||
|
(localRecips, remoteRecips, fwdHosts, action) <-
|
||||||
|
C.makeServerInput Nothing maybeSummary audience $ AP.CreateActivity $ AP.Create (AP.CreateTeam detail Nothing) Nothing
|
||||||
|
result <-
|
||||||
|
runExceptT $
|
||||||
|
handleViaActor personID Nothing localRecips remoteRecips fwdHosts action
|
||||||
|
|
||||||
|
case result of
|
||||||
|
Left e -> do
|
||||||
|
setMessage $ toHtml e
|
||||||
|
redirect GroupNewR
|
||||||
|
Right createID -> do
|
||||||
|
maybeGroupID <- runDB $ getKeyBy $ UniqueGroupCreate createID
|
||||||
|
case maybeGroupID of
|
||||||
|
Nothing -> error "Can't find the newly created group"
|
||||||
|
Just groupID -> do
|
||||||
|
groupHash <- encodeKeyHashid groupID
|
||||||
|
setMessage "New group created"
|
||||||
|
redirect $ GroupR groupHash
|
||||||
|
|
||||||
getGroupR :: KeyHashid Group -> Handler TypedContent
|
getGroupR :: KeyHashid Group -> Handler TypedContent
|
||||||
getGroupR groupHash = do
|
getGroupR groupHash = do
|
||||||
groupID <- decodeKeyHashid404 groupHash
|
groupID <- decodeKeyHashid404 groupHash
|
||||||
|
@ -194,8 +226,7 @@ getGroupMembersR groupHash = do
|
||||||
members <- runDB $ do
|
members <- runDB $ do
|
||||||
_group <- get404 groupID
|
_group <- get404 groupID
|
||||||
grants <-
|
grants <-
|
||||||
--getTopicGrants CollabTopicGroupCollab CollabTopicGroupGroup groupID
|
getTopicGrants CollabTopicGroupCollab CollabTopicGroupGroup groupID
|
||||||
pure ([] :: [(AP.Role, Either PersonId RemoteActorId, (), UTCTime)])
|
|
||||||
for grants $ \ (role, actor, _ct, time) ->
|
for grants $ \ (role, actor, _ct, time) ->
|
||||||
(role,time,) <$> bitraverse pure (getRemoteActorURI <=< getJust) actor
|
(role,time,) <$> bitraverse pure (getRemoteActorURI <=< getJust) actor
|
||||||
h <- asksSite siteInstanceHost
|
h <- asksSite siteInstanceHost
|
||||||
|
@ -230,16 +261,14 @@ getGroupMembersR groupHash = do
|
||||||
provideHtmlAndAP membersAP $ getHtml groupID
|
provideHtmlAndAP membersAP $ getHtml groupID
|
||||||
where
|
where
|
||||||
getHtml groupID = do
|
getHtml groupID = do
|
||||||
(group, actor, members{-, invites, joins-}) <- handlerToWidget $ runDB $ do
|
(group, actor, members, invites, joins) <- handlerToWidget $ runDB $ do
|
||||||
group <- get404 groupID
|
group <- get404 groupID
|
||||||
actor <- getJust $ groupActor group
|
actor <- getJust $ groupActor group
|
||||||
members <- do
|
members <- do
|
||||||
grants <-
|
grants <-
|
||||||
--getTopicGrants CollabTopicGroupCollab CollabTopicGroupGroup groupID
|
getTopicGrants CollabTopicGroupCollab CollabTopicGroupGroup groupID
|
||||||
pure ([] :: [(AP.Role, Either PersonId RemoteActorId, (), UTCTime)])
|
|
||||||
for grants $ \ (role, actor, ct, time) ->
|
for grants $ \ (role, actor, ct, time) ->
|
||||||
(,role,ct,time) <$> getPersonWidgetInfo actor
|
(,role,ct,time) <$> getPersonWidgetInfo actor
|
||||||
{-
|
|
||||||
invites <- do
|
invites <- do
|
||||||
invites' <-
|
invites' <-
|
||||||
getTopicInvites CollabTopicGroupCollab CollabTopicGroupGroup groupID
|
getTopicInvites CollabTopicGroupCollab CollabTopicGroupGroup groupID
|
||||||
|
@ -253,8 +282,7 @@ getGroupMembersR groupHash = do
|
||||||
getTopicJoins CollabTopicGroupCollab CollabTopicGroupGroup groupID
|
getTopicJoins CollabTopicGroupCollab CollabTopicGroupGroup groupID
|
||||||
for joins' $ \ (recip, time, role) ->
|
for joins' $ \ (recip, time, role) ->
|
||||||
(,time,role) <$> getPersonWidgetInfo recip
|
(,time,role) <$> getPersonWidgetInfo recip
|
||||||
-}
|
return (group, actor, members, invites, joins)
|
||||||
return (group, actor, members{-, invites, joins-})
|
|
||||||
$(widgetFile "group/members")
|
$(widgetFile "group/members")
|
||||||
where
|
where
|
||||||
grabPerson actorID = do
|
grabPerson actorID = do
|
||||||
|
@ -290,44 +318,6 @@ getGroupsR = do
|
||||||
return sharer
|
return sharer
|
||||||
defaultLayout $(widgetFile "group/list")
|
defaultLayout $(widgetFile "group/list")
|
||||||
|
|
||||||
postGroupsR :: Handler Html
|
|
||||||
postGroupsR = do
|
|
||||||
((result, widget), enctype) <- runFormPost newGroupForm
|
|
||||||
case result of
|
|
||||||
FormSuccess ng -> do
|
|
||||||
now <- liftIO getCurrentTime
|
|
||||||
pid <- requireAuthId
|
|
||||||
runDB $ do
|
|
||||||
let sharer = Sharer
|
|
||||||
{ sharerIdent = ngIdent ng
|
|
||||||
, sharerName = ngName ng
|
|
||||||
, sharerCreated = now
|
|
||||||
}
|
|
||||||
sid <- insert sharer
|
|
||||||
let group = Group
|
|
||||||
{ groupIdent = sid
|
|
||||||
}
|
|
||||||
gid <- insert group
|
|
||||||
let member = GroupMember
|
|
||||||
{ groupMemberPerson = pid
|
|
||||||
, groupMemberGroup = gid
|
|
||||||
, groupMemberRole = GRAdmin
|
|
||||||
, groupMemberJoined = now
|
|
||||||
}
|
|
||||||
insert_ member
|
|
||||||
redirect $ SharerR $ ngIdent ng
|
|
||||||
FormMissing -> do
|
|
||||||
setMessage "Field(s) missing"
|
|
||||||
defaultLayout $(widgetFile "group/new")
|
|
||||||
FormFailure _l -> do
|
|
||||||
setMessage "Group creation failed, see errors below"
|
|
||||||
defaultLayout $(widgetFile "group/new")
|
|
||||||
|
|
||||||
getGroupNewR :: Handler Html
|
|
||||||
getGroupNewR = do
|
|
||||||
((_result, widget), enctype) <- runFormPost newGroupForm
|
|
||||||
defaultLayout $(widgetFile "group/new")
|
|
||||||
|
|
||||||
getgid :: ShrIdent -> AppDB GroupId
|
getgid :: ShrIdent -> AppDB GroupId
|
||||||
getgid shar = do
|
getgid shar = do
|
||||||
Entity s _ <- getBy404 $ UniqueSharer shar
|
Entity s _ <- getBy404 $ UniqueSharer shar
|
||||||
|
|
|
@ -3047,6 +3047,8 @@ changes hLocal ctx =
|
||||||
"OutboxItem"
|
"OutboxItem"
|
||||||
-- 550
|
-- 550
|
||||||
, addUnique' "Group" "Create" ["create"]
|
, addUnique' "Group" "Create" ["create"]
|
||||||
|
-- 551
|
||||||
|
, addEntities model_551_group_collab
|
||||||
]
|
]
|
||||||
|
|
||||||
migrateDB
|
migrateDB
|
||||||
|
|
|
@ -860,6 +860,7 @@ data ResourceWithCollections u = ResourceWithCollections
|
||||||
{ rwcResource :: Resource u
|
{ rwcResource :: Resource u
|
||||||
, rwcCollabs :: Maybe LocalURI
|
, rwcCollabs :: Maybe LocalURI
|
||||||
, rwcComponents :: Maybe LocalURI
|
, rwcComponents :: Maybe LocalURI
|
||||||
|
, rwcMembers :: Maybe LocalURI
|
||||||
}
|
}
|
||||||
|
|
||||||
instance ActivityPub ResourceWithCollections where
|
instance ActivityPub ResourceWithCollections where
|
||||||
|
@ -869,10 +870,12 @@ instance ActivityPub ResourceWithCollections where
|
||||||
fmap (h,) $ ResourceWithCollections r
|
fmap (h,) $ ResourceWithCollections r
|
||||||
<$> withAuthorityMaybeO h (o .:? "collaborators")
|
<$> withAuthorityMaybeO h (o .:? "collaborators")
|
||||||
<*> withAuthorityMaybeO h (o .:? "components")
|
<*> withAuthorityMaybeO h (o .:? "components")
|
||||||
toSeries h (ResourceWithCollections r collabs comps)
|
<*> withAuthorityMaybeO h (o .:? "members")
|
||||||
|
toSeries h (ResourceWithCollections r collabs comps members)
|
||||||
= toSeries h r
|
= toSeries h r
|
||||||
<> "collaborators" .=? (ObjURI h <$> collabs)
|
<> "collaborators" .=? (ObjURI h <$> collabs)
|
||||||
<> "components" .=? (ObjURI h <$> comps)
|
<> "components" .=? (ObjURI h <$> comps)
|
||||||
|
<> "members" .=? (ObjURI h <$> members)
|
||||||
|
|
||||||
data Project u = Project
|
data Project u = Project
|
||||||
{ projectActor :: Actor u
|
{ projectActor :: Actor u
|
||||||
|
|
|
@ -27,3 +27,33 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
|
||||||
<td>^{personLinkFedW person}
|
<td>^{personLinkFedW person}
|
||||||
<td>#{showDate since}
|
<td>#{showDate since}
|
||||||
$#<td>^{buttonW POST "Remove" (GroupRemoveR groupHash ctID)}
|
$#<td>^{buttonW POST "Remove" (GroupRemoveR groupHash ctID)}
|
||||||
|
|
||||||
|
<h2>Invites
|
||||||
|
|
||||||
|
<table>
|
||||||
|
<tr>
|
||||||
|
<th>Inviter
|
||||||
|
<th>Invitee
|
||||||
|
<th>Role
|
||||||
|
<th>Time
|
||||||
|
$forall (inviter, invitee, time, role) <- invites
|
||||||
|
<tr>
|
||||||
|
<td>^{personLinkFedW inviter}
|
||||||
|
<td>^{personLinkFedW invitee}
|
||||||
|
<td>#{show role}
|
||||||
|
<td>#{showDate time}
|
||||||
|
|
||||||
|
$#<a href=@{ProjectInviteR projectHash}>Invite…
|
||||||
|
|
||||||
|
<h2>Joins
|
||||||
|
|
||||||
|
<table>
|
||||||
|
<tr>
|
||||||
|
<th>Joiner
|
||||||
|
<th>Role
|
||||||
|
<th>Time
|
||||||
|
$forall (joiner, time, role) <- joins
|
||||||
|
<tr>
|
||||||
|
<td>^{personLinkFedW joiner}
|
||||||
|
<td>#{show role}
|
||||||
|
<td>#{showDate time}
|
||||||
|
|
|
@ -1,6 +1,6 @@
|
||||||
$# This file is part of Vervis.
|
$# This file is part of Vervis.
|
||||||
$#
|
$#
|
||||||
$# Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
|
$# Written in 2016, 2023 by fr33domlover <fr33domlover@riseup.net>.
|
||||||
$#
|
$#
|
||||||
$# ♡ Copying is an act of love. Please copy, reuse and share.
|
$# ♡ Copying is an act of love. Please copy, reuse and share.
|
||||||
$#
|
$#
|
||||||
|
@ -12,7 +12,7 @@ $# You should have received a copy of the CC0 Public Domain Dedication along
|
||||||
$# with this software. If not, see
|
$# with this software. If not, see
|
||||||
$# <http://creativecommons.org/publicdomain/zero/1.0/>.
|
$# <http://creativecommons.org/publicdomain/zero/1.0/>.
|
||||||
|
|
||||||
<form method=POST action=@{GroupsR} enctype=#{enctype}>
|
<form method=POST action=@{GroupNewR} enctype=#{enctype}>
|
||||||
^{widget}
|
^{widget}
|
||||||
<div class="submit">
|
<div class="submit">
|
||||||
<input type="submit">
|
<input type="submit">
|
||||||
|
|
|
@ -25,17 +25,26 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
|
||||||
<a href=@{KeysR}>
|
<a href=@{KeysR}>
|
||||||
SSH key settings
|
SSH key settings
|
||||||
<li>
|
<li>
|
||||||
<a href=@{RepoNewR}>
|
Create a new…
|
||||||
Create a new repository
|
<ul>
|
||||||
<li>
|
|
||||||
<a href=@{DeckNewR}>
|
|
||||||
Create a new ticket tracker
|
|
||||||
<li>
|
|
||||||
<a href=@{LoomNewR}>
|
|
||||||
Create a new patch tracker
|
|
||||||
<li>
|
<li>
|
||||||
<a href=@{ProjectNewR}>
|
<a href=@{ProjectNewR}>
|
||||||
Create a new project
|
project
|
||||||
|
<li>
|
||||||
|
<a href=@{GroupNewR}>
|
||||||
|
team
|
||||||
|
<li>
|
||||||
|
component:
|
||||||
|
<ul>
|
||||||
|
<li>
|
||||||
|
<a href=@{RepoNewR}>
|
||||||
|
repository
|
||||||
|
<li>
|
||||||
|
<a href=@{DeckNewR}>
|
||||||
|
ticket tracker
|
||||||
|
<li>
|
||||||
|
<a href=@{LoomNewR}>
|
||||||
|
patch tracker
|
||||||
<li>
|
<li>
|
||||||
<a href=@{PublishOfferMergeR}>
|
<a href=@{PublishOfferMergeR}>
|
||||||
Open a merge request
|
Open a merge request
|
||||||
|
@ -57,7 +66,14 @@ $# Comment on a ticket or merge request
|
||||||
|
|
||||||
<h2>Your teams
|
<h2>Your teams
|
||||||
|
|
||||||
<p>You aren't a member of any teams at the moment.
|
<ul>
|
||||||
|
$forall (Entity groupID _, Entity _ actor, Entity _ (Collab role)) <- groups
|
||||||
|
<li>
|
||||||
|
[
|
||||||
|
#{show role}
|
||||||
|
]
|
||||||
|
<a href=@{GroupR $ hashGroup groupID}>
|
||||||
|
&#{keyHashidText $ hashGroup groupID} #{actorName actor}
|
||||||
|
|
||||||
<h2>Your repos
|
<h2>Your repos
|
||||||
|
|
||||||
|
|
|
@ -156,6 +156,8 @@
|
||||||
|
|
||||||
---- Group ------------------------------------------------------------------
|
---- Group ------------------------------------------------------------------
|
||||||
|
|
||||||
|
/new-group GroupNewR GET POST
|
||||||
|
|
||||||
/groups/#GroupKeyHashid GroupR GET
|
/groups/#GroupKeyHashid GroupR GET
|
||||||
/groups/#GroupKeyHashid/inbox GroupInboxR GET POST
|
/groups/#GroupKeyHashid/inbox GroupInboxR GET POST
|
||||||
/groups/#GroupKeyHashid/outbox GroupOutboxR GET
|
/groups/#GroupKeyHashid/outbox GroupOutboxR GET
|
||||||
|
|
Loading…
Reference in a new issue