diff --git a/src/Vervis/Actor/Person/Client.hs b/src/Vervis/Actor/Person/Client.hs
index 1f53280..a4c2dda 100644
--- a/src/Vervis/Actor/Person/Client.hs
+++ b/src/Vervis/Actor/Person/Client.hs
@@ -211,7 +211,7 @@ clientAdd now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHosts a
manager <- asksEnv envHttpManager
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'"
- 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) $
throwE "Add target isn't a components list"
@@ -845,8 +845,8 @@ clientInvite now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost
manager <- asksEnv envHttpManager
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'"
- AP.ResourceWithCollections _ mluCollabs mluComps <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
- unless (mluCollabs == Just luColl || mluComps == Just luColl) $
+ AP.ResourceWithCollections _ mluCollabs mluComps mluMembers <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
+ unless (mluCollabs == Just luColl || mluComps == Just luColl || mluMembers == Just luColl) $
throwE "Invite target isn't a collabs/components list"
instanceID <-
@@ -1079,8 +1079,8 @@ clientRemove now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost
manager <- asksEnv envHttpManager
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'"
- AP.ResourceWithCollections _ mluCollabs _ <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
- unless (mluCollabs == Just luColl) $
+ AP.ResourceWithCollections _ mluCollabs _ mluMembers <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
+ unless (mluCollabs == Just luColl || mluMembers == Just luColl) $
throwE "Remove origin isn't a collabs list"
return $ ObjURI h lu
)
diff --git a/src/Vervis/Client.hs b/src/Vervis/Client.hs
index e63fd11..c4ae8a1 100644
--- a/src/Vervis/Client.hs
+++ b/src/Vervis/Client.hs
@@ -38,6 +38,7 @@ module Vervis.Client
, createLoom
, createRepo
, createProject
+ , createGroup
, invite
, remove
, inviteComponent
@@ -1050,6 +1051,27 @@ createProject senderHash name desc = do
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
:: PersonId
-> FedURI
@@ -1090,8 +1112,8 @@ invite personID uRecipient uResourceCollabs role = do
manager <- asksSite appHttpManager
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'"
- AP.ResourceWithCollections _ mluCollabs _ <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
- unless (mluCollabs == Just luColl) $
+ AP.ResourceWithCollections _ mluCollabs _ mluMembers <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
+ unless (mluCollabs == Just luColl || mluMembers == Just luColl) $
throwE "Invite target isn't a collabs list"
return $ ObjURI h lu
)
@@ -1204,8 +1226,8 @@ remove personID uRecipient uResourceCollabs = do
manager <- asksSite appHttpManager
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'"
- AP.ResourceWithCollections _ mluCollabs _ <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
- unless (mluCollabs == Just luColl) $
+ AP.ResourceWithCollections _ mluCollabs _ mluMembers <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
+ unless (mluCollabs == Just luColl || mluMembers == Just luColl) $
throwE "Remove origin isn't a collabs list"
return $ ObjURI h lu
)
diff --git a/src/Vervis/Data/Collab.hs b/src/Vervis/Data/Collab.hs
index c895b44..89d076b 100644
--- a/src/Vervis/Data/Collab.hs
+++ b/src/Vervis/Data/Collab.hs
@@ -100,12 +100,14 @@ parseGrantResource (RepoR r) = Just $ GrantResourceRepo r
parseGrantResource (DeckR d) = Just $ GrantResourceDeck d
parseGrantResource (LoomR l) = Just $ GrantResourceLoom l
parseGrantResource (ProjectR l) = Just $ GrantResourceProject l
+parseGrantResource (GroupR l) = Just $ GrantResourceGroup l
parseGrantResource _ = Nothing
parseGrantResourceCollabs (RepoCollabsR r) = Just $ GrantResourceRepo r
parseGrantResourceCollabs (DeckCollabsR d) = Just $ GrantResourceDeck d
parseGrantResourceCollabs (LoomCollabsR l) = Just $ GrantResourceLoom l
parseGrantResourceCollabs (ProjectCollabsR l) = Just $ GrantResourceProject l
+parseGrantResourceCollabs (GroupMembersR l) = Just $ GrantResourceGroup l
parseGrantResourceCollabs _ = Nothing
data GrantRecipBy f = GrantRecipPerson (f Person)
diff --git a/src/Vervis/Form/Tracker.hs b/src/Vervis/Form/Tracker.hs
index 66c5cf4..98c2c68 100644
--- a/src/Vervis/Form/Tracker.hs
+++ b/src/Vervis/Form/Tracker.hs
@@ -18,6 +18,8 @@ module Vervis.Form.Tracker
, newDeckForm
, NewProject (..)
, newProjectForm
+ , NewGroup (..)
+ , newGroupForm
, NewLoom (..)
, newLoomForm
, DeckInvite (..)
@@ -73,6 +75,16 @@ newProjectForm = renderDivs $ NewProject
<$> areq textField "Name*" 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
{ nlName :: Text
, nlDesc :: Text
diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs
index dcc07cb..ebb12e3 100644
--- a/src/Vervis/Foundation.hs
+++ b/src/Vervis/Foundation.hs
@@ -872,6 +872,7 @@ instance YesodBreadcrumbs App where
PersonStampR p k -> ("Stamp #" <> keyHashidText k, Just $ PersonR p)
+ GroupNewR -> ("New Team", Just HomeR)
GroupR g -> ("Team &" <> keyHashidText g, Just HomeR)
GroupInboxR g -> ("Inbox", Just $ GroupR g)
GroupOutboxR g -> ("Outbox", Just $ GroupR g)
diff --git a/src/Vervis/Handler/Client.hs b/src/Vervis/Handler/Client.hs
index 492da48..4bf69bd 100644
--- a/src/Vervis/Handler/Client.hs
+++ b/src/Vervis/Handler/Client.hs
@@ -130,7 +130,7 @@ getHomeR = do
where
personalOverview :: Entity Person -> Handler Html
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.on $ repo E.^. RepoActor E.==. actor E.^. ActorId
E.on $ topic E.^. CollabTopicRepoRepo E.==. repo E.^. RepoId
@@ -171,10 +171,21 @@ getHomeR = do
E.orderBy [E.asc $ project E.^. ProjectId]
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
hashDeck <- getEncodeKeyHashid
hashLoom <- getEncodeKeyHashid
hashProject <- getEncodeKeyHashid
+ hashGroup <- getEncodeKeyHashid
defaultLayout $(widgetFile "personal-overview")
getBrowseR :: Handler Html
diff --git a/src/Vervis/Handler/Group.hs b/src/Vervis/Handler/Group.hs
index c14b38c..691f18b 100644
--- a/src/Vervis/Handler/Group.hs
+++ b/src/Vervis/Handler/Group.hs
@@ -14,7 +14,10 @@
-}
module Vervis.Handler.Group
- ( getGroupR
+ ( getGroupNewR
+ , postGroupNewR
+
+ , getGroupR
, getGroupInboxR
, postGroupInboxR
, getGroupOutboxR
@@ -33,8 +36,6 @@ module Vervis.Handler.Group
{-
, getGroupsR
- , postGroupsR
- , getGroupNewR
, postGroupMembersR
, getGroupMemberNewR
, getGroupMemberR
@@ -118,6 +119,37 @@ import Vervis.Widget.Tracker
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 groupHash = do
groupID <- decodeKeyHashid404 groupHash
@@ -194,8 +226,7 @@ getGroupMembersR groupHash = do
members <- runDB $ do
_group <- get404 groupID
grants <-
- --getTopicGrants CollabTopicGroupCollab CollabTopicGroupGroup groupID
- pure ([] :: [(AP.Role, Either PersonId RemoteActorId, (), UTCTime)])
+ getTopicGrants CollabTopicGroupCollab CollabTopicGroupGroup groupID
for grants $ \ (role, actor, _ct, time) ->
(role,time,) <$> bitraverse pure (getRemoteActorURI <=< getJust) actor
h <- asksSite siteInstanceHost
@@ -230,16 +261,14 @@ getGroupMembersR groupHash = do
provideHtmlAndAP membersAP $ getHtml groupID
where
getHtml groupID = do
- (group, actor, members{-, invites, joins-}) <- handlerToWidget $ runDB $ do
+ (group, actor, members, invites, joins) <- handlerToWidget $ runDB $ do
group <- get404 groupID
actor <- getJust $ groupActor group
members <- do
grants <-
- --getTopicGrants CollabTopicGroupCollab CollabTopicGroupGroup groupID
- pure ([] :: [(AP.Role, Either PersonId RemoteActorId, (), UTCTime)])
+ getTopicGrants CollabTopicGroupCollab CollabTopicGroupGroup groupID
for grants $ \ (role, actor, ct, time) ->
(,role,ct,time) <$> getPersonWidgetInfo actor
- {-
invites <- do
invites' <-
getTopicInvites CollabTopicGroupCollab CollabTopicGroupGroup groupID
@@ -253,8 +282,7 @@ getGroupMembersR groupHash = do
getTopicJoins CollabTopicGroupCollab CollabTopicGroupGroup groupID
for joins' $ \ (recip, time, role) ->
(,time,role) <$> getPersonWidgetInfo recip
- -}
- return (group, actor, members{-, invites, joins-})
+ return (group, actor, members, invites, joins)
$(widgetFile "group/members")
where
grabPerson actorID = do
@@ -290,44 +318,6 @@ getGroupsR = do
return sharer
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 shar = do
Entity s _ <- getBy404 $ UniqueSharer shar
diff --git a/src/Vervis/Migration.hs b/src/Vervis/Migration.hs
index 245ee8d..9fe65e2 100644
--- a/src/Vervis/Migration.hs
+++ b/src/Vervis/Migration.hs
@@ -3047,6 +3047,8 @@ changes hLocal ctx =
"OutboxItem"
-- 550
, addUnique' "Group" "Create" ["create"]
+ -- 551
+ , addEntities model_551_group_collab
]
migrateDB
diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs
index 939fc2a..db3e34c 100644
--- a/src/Web/ActivityPub.hs
+++ b/src/Web/ActivityPub.hs
@@ -860,6 +860,7 @@ data ResourceWithCollections u = ResourceWithCollections
{ rwcResource :: Resource u
, rwcCollabs :: Maybe LocalURI
, rwcComponents :: Maybe LocalURI
+ , rwcMembers :: Maybe LocalURI
}
instance ActivityPub ResourceWithCollections where
@@ -869,10 +870,12 @@ instance ActivityPub ResourceWithCollections where
fmap (h,) $ ResourceWithCollections r
<$> withAuthorityMaybeO h (o .:? "collaborators")
<*> withAuthorityMaybeO h (o .:? "components")
- toSeries h (ResourceWithCollections r collabs comps)
+ <*> withAuthorityMaybeO h (o .:? "members")
+ toSeries h (ResourceWithCollections r collabs comps members)
= toSeries h r
<> "collaborators" .=? (ObjURI h <$> collabs)
<> "components" .=? (ObjURI h <$> comps)
+ <> "members" .=? (ObjURI h <$> members)
data Project u = Project
{ projectActor :: Actor u
diff --git a/templates/group/members.hamlet b/templates/group/members.hamlet
index c5ac3f7..a6ac257 100644
--- a/templates/group/members.hamlet
+++ b/templates/group/members.hamlet
@@ -27,3 +27,33 @@ $# .
| ^{personLinkFedW person}
| #{showDate since}
$# | ^{buttonW POST "Remove" (GroupRemoveR groupHash ctID)}
+
+Invites
+
+ |