UI: Deck, Group, Project: Enhance collaborators view, prepare to add teams

README.md

@@ -283,6 +283,7 @@ Haskell modules in `src`:
 - `Vervis.Data`
 - `Vervis.Persist`
 - `Vervis.Fetch`
+- `Vervis.Serve`
 - `Vervis.Query`
 - `Vervis.Web`
 - Primary web app support modules:
@@ -292,8 +293,7 @@ Haskell modules in `src`:
   - `Vervis.Model`
   - `Vervis.Migration`
 - Primary web app logic modules:
-  - `Vervis.API`
+  - `Vervis.Actor`
-  - `Vervis.Federation`
   - `Vervis.Handler`
   - `Vervis.Client`
 - `Vervis.Ssh`

src/Vervis/Form/Tracker.hs

@@ -30,6 +30,7 @@ module Vervis.Form.Tracker
     , projectInviteCompForm
     , GroupInvite (..)
     , groupInviteForm
+    , inviteForm
     --, NewProjectCollab (..)
     --, newProjectCollabForm
     --, editProjectForm
@@ -217,6 +218,13 @@ groupInviteForm groupID = renderDivs $ GroupInvite
             l
     selectRole = selectField optionsEnum
 
+inviteForm = renderDivs $ (,)
+    <$> areq fedUriField "Person*" Nothing
+    <*> areq selectRole  "Role*"   Nothing
+    where
+    selectRole :: Field Handler AP.Role
+    selectRole = selectField optionsEnum
+
 {-
 editProjectAForm :: SharerId -> Entity Project -> AForm Handler Project
 editProjectAForm sid (Entity jid project) = Project

src/Vervis/Foundation.hs

@@ -960,8 +960,6 @@ instance YesodBreadcrumbs App where
         DeckNewR        -> ("New Ticket Tracker", Just HomeR)
         DeckDeleteR _   -> ("", Nothing)
         DeckEditR d     -> ("Edit", Just $ DeckR d)
-        DeckFollowR _   -> ("", Nothing)
-        DeckUnfollowR _ -> ("", Nothing)
 
         DeckStampR d k -> ("Stamp #" <> keyHashidText k, Just $ DeckR d)
 

src/Vervis/Handler/Deck.hs

@@ -33,13 +33,10 @@ module Vervis.Handler.Deck
     , postDeckDeleteR
     , getDeckEditR
     , postDeckEditR
-    , postDeckFollowR
-    , postDeckUnfollowR
 
     , getDeckStampR
 
     , getDeckCollabsR
-    , getDeckInviteR
     , postDeckInviteR
     , postDeckRemoveR
     , getDeckProjectsR
@@ -134,6 +131,7 @@ import Vervis.Paginate
 import Vervis.Persist.Actor
 import Vervis.Persist.Collab
 import Vervis.Recipient
+import Vervis.Serve.Collab
 import Vervis.Settings
 import Vervis.Ticket
 import Vervis.TicketFilter
@@ -419,175 +417,36 @@ postDeckEditR _ = do
             defaultLayout $(widgetFile "project/edit")
     -}
 
-postDeckFollowR :: KeyHashid Deck -> Handler ()
-postDeckFollowR _ = error "Temporarily disabled"
-
-postDeckUnfollowR :: KeyHashid Deck -> Handler ()
-postDeckUnfollowR _ = error "Temporarily disabled"
-
 getDeckStampR :: KeyHashid Deck -> KeyHashid SigKey -> Handler TypedContent
 getDeckStampR = servePerActorKey deckActor LocalActorDeck
 
 getDeckCollabsR :: KeyHashid Deck -> Handler TypedContent
 getDeckCollabsR deckHash = do
     deckID <- decodeKeyHashid404 deckHash
-    collabs <- runDB $ do
+    (deck, actor) <- runDB $ do
-        deck <- get404 deckID
-        grants <- getTopicGrants $ deckResource deck
-        for grants $ \ (role, actor, _ct, time) ->
-            (role,time,) <$> bitraverse pure (getRemoteActorURI <=< getJust) actor
-    h <- asksSite siteInstanceHost
-    encodeRouteLocal <- getEncodeRouteLocal
-    encodeRouteHome <- getEncodeRouteHome
-    hashPerson <- getEncodeKeyHashid
-    let makeItem (role, time, i) = AP.Relationship
-            { AP.relationshipId           = Nothing
-            , AP.relationshipExtraTypes   = []
-            , AP.relationshipSubject      = encodeRouteHome $ DeckR deckHash
-            , AP.relationshipProperty     = Left AP.RelHasCollab
-            , AP.relationshipObject       =
-                case i of
-                    Left personID -> encodeRouteHome $ PersonR $ hashPerson personID
-                    Right u -> u
-            , AP.relationshipAttributedTo = encodeRouteLocal $ DeckR deckHash
-            , AP.relationshipPublished    = Just time
-            , AP.relationshipUpdated      = Nothing
-            , AP.relationshipInstrument   = Just role
-            }
-        collabsAP = AP.Collection
-            { AP.collectionId         = encodeRouteLocal $ DeckCollabsR deckHash
-            , AP.collectionType       = CollectionTypeUnordered
-            , AP.collectionTotalItems = Just $ length collabs
-            , AP.collectionCurrent    = Nothing
-            , AP.collectionFirst      = Nothing
-            , AP.collectionLast       = Nothing
-            , AP.collectionItems      = map (Doc h . makeItem) collabs
-            , AP.collectionContext    =
-                Just $ encodeRouteLocal $ DeckR deckHash
-            }
-    provideHtmlAndAP collabsAP $ getHtml deckID
-    where
-    getHtml deckID = do
-        (deck, actor, collabs, invites, joins) <- handlerToWidget $ runDB $ do
         deck <- get404 deckID
         actor <- getJust $ deckActor deck
-            collabs <- do
+        return (deck, actor)
-                grants <- getTopicGrants $ deckResource deck
+    serveCollabs
-                for grants $ \ (role, actor, ct, time) ->
+        AP.RelHasCollab
-                    (,role,ct,time) <$> getPersonWidgetInfo actor
+        (deckResource deck)
-            invites <- do
+        (DeckR deckHash)
-                invites' <- getTopicInvites $ deckResource deck
+        (DeckCollabsR deckHash)
-                for invites' $ \ (inviter, recip, time, role) -> (,,,)
+        (DeckRemoveR deckHash)
-                    <$> (getPersonWidgetInfo =<< bitraverse grabPerson pure inviter)
+        (DeckInviteR deckHash)
-                    <*> getPersonWidgetInfo recip
+        (deckNavW (Entity deckID deck) actor)
-                    <*> pure time
-                    <*> pure role
-            joins <- do
-                joins' <- getTopicJoins $ deckResource deck
-                for joins' $ \ (recip, time, role) ->
-                    (,time,role) <$> getPersonWidgetInfo recip
-            return (deck, actor, collabs, invites, joins)
-        $(widgetFile "deck/collab/list")
-        where
-        grabPerson actorID = do
-            actorByKey <- getLocalActor actorID
-            case actorByKey of
-                LocalActorPerson personID -> return personID
-                _ -> error "Surprise, local inviter actor isn't a Person"
-
-getDeckInviteR :: KeyHashid Deck -> Handler Html
-getDeckInviteR deckHash = do
-    deckID <- decodeKeyHashid404 deckHash
-    ((_result, widget), enctype) <- runFormPost $ deckInviteForm deckID
-    defaultLayout $(widgetFile "deck/collab/new")
 
 postDeckInviteR :: KeyHashid Deck -> Handler Html
 postDeckInviteR deckHash = do
     deckID <- decodeKeyHashid404 deckHash
-    DeckInvite recipPersonID role <-
+    resourceID <- runDB $ deckResource <$> get404 deckID
-        runFormPostRedirect (DeckInviteR deckHash) $ deckInviteForm deckID
+    serveInviteCollab resourceID (DeckCollabsR deckHash)
-
-    personEntity@(Entity personID person) <- requireAuth
-    personHash <- encodeKeyHashid personID
-    recipPersonHash <- encodeKeyHashid recipPersonID
-    encodeRouteHome <- getEncodeRouteHome
-
-    result <- runExceptT $ do
-        (maybeSummary, audience, invite) <- do
-            let uRecipient = encodeRouteHome $ PersonR recipPersonHash
-                uResourceCollabs = encodeRouteHome $ DeckCollabsR deckHash
-            C.invite personID uRecipient uResourceCollabs role
-        grantID <- do
-            maybeItem <- lift $ runDB $ do
-                resourceID <- deckResource <$> get404 deckID
-                getGrant resourceID personID
-            fromMaybeE maybeItem "You need to be a collaborator in the Deck to invite people"
-        grantHash <- encodeKeyHashid grantID
-        let uCap = encodeRouteHome $ DeckOutboxItemR deckHash grantHash
-        (localRecips, remoteRecips, fwdHosts, action) <-
-            C.makeServerInput (Just uCap) maybeSummary audience $ AP.InviteActivity invite
-        let cap =
-                Left (LocalActorDeck deckID, LocalActorDeck deckHash, grantID)
-        handleViaActor
-            personID (Just cap) localRecips remoteRecips fwdHosts action
-
-    case result of
-        Left e -> do
-            setMessage $ toHtml e
-            redirect $ DeckInviteR deckHash
-        Right inviteID -> do
-            setMessage "Invite sent"
-            redirect $ DeckCollabsR deckHash
 
 postDeckRemoveR :: KeyHashid Deck -> CollabId -> Handler Html
 postDeckRemoveR deckHash collabID = do
     deckID <- decodeKeyHashid404 deckHash
-
+    resourceID <- runDB $ deckResource <$> get404 deckID
-    personEntity@(Entity personID person) <- requireAuth
+    serveRemoveCollab resourceID (DeckCollabsR deckHash) collabID
-    personHash <- encodeKeyHashid personID
-    encodeRouteHome <- getEncodeRouteHome
-
-    result <- runExceptT $ do
-        mpidOrU <- lift $ runDB $ runMaybeT $ do
-            Collab _ resourceID <- MaybeT $ get collabID
-            d <- MaybeT $ get deckID
-            guard $ resourceID == deckResource d
-            _ <- MaybeT $ getBy $ UniqueCollabEnable collabID
-            member <-
-                Left <$> MaybeT (getValBy $ UniqueCollabRecipLocal collabID) <|>
-                Right <$> MaybeT (getValBy $ UniqueCollabRecipRemote collabID)
-            lift $
-                (resourceID,) <$>
-                bitraverse
-                    (pure . collabRecipLocalPerson)
-                    (getRemoteActorURI <=< getJust . collabRecipRemoteActor)
-                    member
-        (resourceID, pidOrU) <- maybe notFound pure mpidOrU
-        (maybeSummary, audience, remove) <- do
-            uRecipient <-
-                case pidOrU of
-                    Left pid -> encodeRouteHome . PersonR <$> encodeKeyHashid pid
-                    Right u -> pure u
-            let uResourceCollabs = encodeRouteHome $ DeckCollabsR deckHash
-            C.remove personID uRecipient uResourceCollabs
-        grantID <- do
-            maybeItem <- lift $ runDB $ getGrant resourceID personID
-            fromMaybeE maybeItem "You need to be a collaborator in the Deck to remove people"
-        grantHash <- encodeKeyHashid grantID
-        let uCap = encodeRouteHome $ DeckOutboxItemR deckHash grantHash
-        (localRecips, remoteRecips, fwdHosts, action) <-
-            C.makeServerInput (Just uCap) maybeSummary audience $ AP.RemoveActivity remove
-        let cap =
-                Left (LocalActorDeck deckID, LocalActorDeck deckHash, grantID)
-        handleViaActor
-            personID (Just cap) localRecips remoteRecips fwdHosts action
-
-    case result of
-        Left e -> do
-            setMessage $ toHtml e
-        Right removeID -> do
-            setMessage "Remove sent"
-    redirect $ DeckCollabsR deckHash
 
 getDeckProjectsR :: KeyHashid Deck -> Handler Html
 getDeckProjectsR deckHash = do

src/Vervis/Handler/Group.hs

@@ -30,7 +30,6 @@ module Vervis.Handler.Group
     , getGroupStampR
 
     , getGroupMembersR
-    , getGroupInviteR
     , postGroupInviteR
     , postGroupRemoveR
 
@@ -127,6 +126,7 @@ import Vervis.Paginate
 import Vervis.Persist.Actor
 import Vervis.Persist.Collab
 import Vervis.Recipient
+import Vervis.Serve.Collab
 import Vervis.Settings
 import Vervis.Ticket
 import Vervis.TicketFilter
@@ -251,163 +251,30 @@ getGroupStampR = servePerActorKey groupActor LocalActorGroup
 getGroupMembersR :: KeyHashid Group -> Handler TypedContent
 getGroupMembersR groupHash = do
     groupID <- decodeKeyHashid404 groupHash
-    members <- runDB $ do
+    (group, actor) <- runDB $ do
-        group <- get404 groupID
-        grants <- getTopicGrants $ groupResource group
-        for grants $ \ (role, actor, _ct, time) ->
-            (role,time,) <$> bitraverse pure (getRemoteActorURI <=< getJust) actor
-    h <- asksSite siteInstanceHost
-    encodeRouteLocal <- getEncodeRouteLocal
-    encodeRouteHome <- getEncodeRouteHome
-    hashPerson <- getEncodeKeyHashid
-    let makeItem (role, time, i) = AP.Relationship
-            { AP.relationshipId           = Nothing
-            , AP.relationshipExtraTypes   = []
-            , AP.relationshipSubject      = encodeRouteHome $ GroupR groupHash
-            , AP.relationshipProperty     = Left AP.RelHasMember
-            , AP.relationshipObject       =
-                case i of
-                    Left personID -> encodeRouteHome $ PersonR $ hashPerson personID
-                    Right u -> u
-            , AP.relationshipAttributedTo = encodeRouteLocal $ GroupR groupHash
-            , AP.relationshipPublished    = Just time
-            , AP.relationshipUpdated      = Nothing
-            , AP.relationshipInstrument   = Just role
-            }
-        membersAP = AP.Collection
-            { AP.collectionId         = encodeRouteLocal $ GroupMembersR groupHash
-            , AP.collectionType       = CollectionTypeUnordered
-            , AP.collectionTotalItems = Just $ length members
-            , AP.collectionCurrent    = Nothing
-            , AP.collectionFirst      = Nothing
-            , AP.collectionLast       = Nothing
-            , AP.collectionItems      = map (Doc h . makeItem) members
-            , AP.collectionContext    =
-                Just $ encodeRouteLocal $ GroupR groupHash
-            }
-    provideHtmlAndAP membersAP $ getHtml groupID
-    where
-    getHtml groupID = do
-        (group, actor, members, invites, joins) <- handlerToWidget $ runDB $ do
         group <- get404 groupID
         actor <- getJust $ groupActor group
-            members <- do
+        return (group, actor)
-                grants <- getTopicGrants $ groupResource group
+    serveCollabs
-                for grants $ \ (role, actor, ct, time) ->
+        AP.RelHasMember
-                    (,role,ct,time) <$> getPersonWidgetInfo actor
+        (groupResource group)
-            invites <- do
+        (GroupR groupHash)
-                invites' <- getTopicInvites $ groupResource group
+        (GroupMembersR groupHash)
-                for invites' $ \ (inviter, recip, time, role) -> (,,,)
+        (GroupRemoveR groupHash)
-                    <$> (getPersonWidgetInfo =<< bitraverse grabPerson pure inviter)
+        (GroupInviteR groupHash)
-                    <*> getPersonWidgetInfo recip
+        (groupNavW (Entity groupID group) actor)
-                    <*> pure time
-                    <*> pure role
-            joins <- do
-                joins' <- getTopicJoins $ groupResource group
-                for joins' $ \ (recip, time, role) ->
-                    (,time,role) <$> getPersonWidgetInfo recip
-            return (group, actor, members, invites, joins)
-        $(widgetFile "group/members")
-        where
-        grabPerson actorID = do
-            actorByKey <- getLocalActor actorID
-            case actorByKey of
-                LocalActorPerson personID -> return personID
-                _ -> error "Surprise, local inviter actor isn't a Person"
-
-getGroupInviteR :: KeyHashid Group -> Handler Html
-getGroupInviteR groupHash = do
-    groupID <- decodeKeyHashid404 groupHash
-    ((_result, widget), enctype) <- runFormPost $ groupInviteForm groupID
-    defaultLayout $(widgetFile "group/member/new")
 
 postGroupInviteR :: KeyHashid Group -> Handler Html
 postGroupInviteR groupHash = do
     groupID <- decodeKeyHashid404 groupHash
-    GroupInvite recipPersonID role <-
+    resourceID <- runDB $ groupResource <$> get404 groupID
-        runFormPostRedirect (GroupInviteR groupHash) $ groupInviteForm groupID
+    serveInviteCollab resourceID (GroupMembersR groupHash)
-
-    personEntity@(Entity personID person) <- requireAuth
-    personHash <- encodeKeyHashid personID
-    recipPersonHash <- encodeKeyHashid recipPersonID
-    encodeRouteHome <- getEncodeRouteHome
-
-    result <- runExceptT $ do
-        (maybeSummary, audience, invite) <- do
-            let uRecipient = encodeRouteHome $ PersonR recipPersonHash
-                uResourceCollabs = encodeRouteHome $ GroupMembersR groupHash
-            C.invite personID uRecipient uResourceCollabs role
-        grantID <- do
-            maybeItem <- lift $ runDB $ do
-                resourceID <- groupResource <$> get404 groupID
-                getGrant resourceID personID
-            fromMaybeE maybeItem "You need to be a collaborator in the Group to invite people"
-        grantHash <- encodeKeyHashid grantID
-        let uCap = encodeRouteHome $ GroupOutboxItemR groupHash grantHash
-        (localRecips, remoteRecips, fwdHosts, action) <-
-            C.makeServerInput (Just uCap) maybeSummary audience $ AP.InviteActivity invite
-        let cap =
-                Left (LocalActorGroup groupID, LocalActorGroup groupHash, grantID)
-        handleViaActor
-            personID (Just cap) localRecips remoteRecips fwdHosts action
-
-    case result of
-        Left e -> do
-            setMessage $ toHtml e
-            redirect $ GroupInviteR groupHash
-        Right inviteID -> do
-            setMessage "Invite sent"
-            redirect $ GroupMembersR groupHash
 
 postGroupRemoveR :: KeyHashid Group -> CollabId -> Handler Html
 postGroupRemoveR groupHash collabID = do
     groupID <- decodeKeyHashid404 groupHash
-
+    resourceID <- runDB $ groupResource <$> get404 groupID
-    personEntity@(Entity personID person) <- requireAuth
+    serveRemoveCollab resourceID (GroupMembersR groupHash) collabID
-    personHash <- encodeKeyHashid personID
-    encodeRouteHome <- getEncodeRouteHome
-
-    result <- runExceptT $ do
-        mpidOrU <- lift $ runDB $ runMaybeT $ do
-            Collab _ resourceID <- MaybeT $ get collabID
-            g <- MaybeT $ get groupID
-            guard $ resourceID == groupResource g
-            _ <- MaybeT $ getBy $ UniqueCollabEnable collabID
-            member <-
-                Left <$> MaybeT (getValBy $ UniqueCollabRecipLocal collabID) <|>
-                Right <$> MaybeT (getValBy $ UniqueCollabRecipRemote collabID)
-            lift $
-                (resourceID,) <$>
-                bitraverse
-                    (pure . collabRecipLocalPerson)
-                    (getRemoteActorURI <=< getJust . collabRecipRemoteActor)
-                    member
-        (resourceID, pidOrU) <- maybe notFound pure mpidOrU
-        (maybeSummary, audience, remove) <- do
-            uRecipient <-
-                case pidOrU of
-                    Left pid -> encodeRouteHome . PersonR <$> encodeKeyHashid pid
-                    Right u -> pure u
-            let uResourceCollabs = encodeRouteHome $ GroupMembersR groupHash
-            C.remove personID uRecipient uResourceCollabs
-        grantID <- do
-            maybeItem <- lift $ runDB $ getGrant resourceID personID
-            fromMaybeE maybeItem "You need to be a collaborator in the Group to remove people"
-        grantHash <- encodeKeyHashid grantID
-        let uCap = encodeRouteHome $ GroupOutboxItemR groupHash grantHash
-        (localRecips, remoteRecips, fwdHosts, action) <-
-            C.makeServerInput (Just uCap) maybeSummary audience $ AP.RemoveActivity remove
-        let cap =
-                Left (LocalActorGroup groupID, LocalActorGroup groupHash, grantID)
-        handleViaActor
-            personID (Just cap) localRecips remoteRecips fwdHosts action
-
-    case result of
-        Left e -> do
-            setMessage $ toHtml e
-        Right removeID ->
-            setMessage "Remove sent"
-    redirect $ GroupMembersR groupHash
 
 getGroupChildrenR :: KeyHashid Group -> Handler TypedContent
 getGroupChildrenR groupHash = do

src/Vervis/Handler/Loom.hs

@@ -102,6 +102,7 @@ import Vervis.Paginate
 import Vervis.Persist.Actor
 import Vervis.Persist.Collab
 import Vervis.Recipient
+import Vervis.Serve.Collab
 import Vervis.Settings
 import Vervis.Ticket
 import Vervis.TicketFilter
@@ -375,7 +376,7 @@ getLoomStampR :: KeyHashid Loom -> KeyHashid SigKey -> Handler TypedContent
 getLoomStampR = servePerActorKey loomActor LocalActorLoom
 
 getLoomCollabsR :: KeyHashid Loom -> Handler TypedContent
-getLoomCollabsR loomHash = error "TODO getLoomCollabsR"
+getLoomCollabsR loomHash = error "TODO"
 
 getLoomProjectsR :: KeyHashid Loom -> Handler Html
 getLoomProjectsR loomHash = do

src/Vervis/Handler/Project.hs

@@ -31,7 +31,6 @@ module Vervis.Handler.Project
     , getProjectStampR
 
     , getProjectCollabsR
-    , getProjectInviteR
     , postProjectInviteR
     , postProjectRemoveR
 
@@ -124,6 +123,7 @@ import Vervis.Paginate
 import Vervis.Persist.Actor
 import Vervis.Persist.Collab
 import Vervis.Recipient
+import Vervis.Serve.Collab
 import Vervis.Settings
 import Vervis.Ticket
 import Vervis.TicketFilter
@@ -251,163 +251,30 @@ getProjectStampR = servePerActorKey projectActor LocalActorProject
 getProjectCollabsR :: KeyHashid Project -> Handler TypedContent
 getProjectCollabsR projectHash = do
     projectID <- decodeKeyHashid404 projectHash
-    collabs <- runDB $ do
+    (project, actor) <- runDB $ do
-        project <- get404 projectID
-        grants <- getTopicGrants $ projectResource project
-        for grants $ \ (role, actor, _ct, time) ->
-            (role,time,) <$> bitraverse pure (getRemoteActorURI <=< getJust) actor
-    h <- asksSite siteInstanceHost
-    encodeRouteLocal <- getEncodeRouteLocal
-    encodeRouteHome <- getEncodeRouteHome
-    hashPerson <- getEncodeKeyHashid
-    let makeItem (role, time, i) = AP.Relationship
-            { AP.relationshipId           = Nothing
-            , AP.relationshipExtraTypes   = []
-            , AP.relationshipSubject      = encodeRouteHome $ ProjectR projectHash
-            , AP.relationshipProperty     = Left AP.RelHasCollab
-            , AP.relationshipObject       =
-                case i of
-                    Left personID -> encodeRouteHome $ PersonR $ hashPerson personID
-                    Right u -> u
-            , AP.relationshipAttributedTo = encodeRouteLocal $ ProjectR projectHash
-            , AP.relationshipPublished    = Just time
-            , AP.relationshipUpdated      = Nothing
-            , AP.relationshipInstrument   = Just role
-            }
-        collabsAP = AP.Collection
-            { AP.collectionId         = encodeRouteLocal $ ProjectCollabsR projectHash
-            , AP.collectionType       = CollectionTypeUnordered
-            , AP.collectionTotalItems = Just $ length collabs
-            , AP.collectionCurrent    = Nothing
-            , AP.collectionFirst      = Nothing
-            , AP.collectionLast       = Nothing
-            , AP.collectionItems      = map (Doc h . makeItem) collabs
-            , AP.collectionContext    =
-                Just $ encodeRouteLocal $ ProjectR projectHash
-            }
-    provideHtmlAndAP collabsAP $ getHtml projectID
-    where
-    getHtml projectID = do
-        (project, actor, collabs, invites, joins) <- handlerToWidget $ runDB $ do
         project <- get404 projectID
         actor <- getJust $ projectActor project
-            collabs <- do
+        return (project, actor)
-                grants <- getTopicGrants $ projectResource project
+    serveCollabs
-                for grants $ \ (role, actor, ct, time) ->
+        AP.RelHasCollab
-                    (,role,ct,time) <$> getPersonWidgetInfo actor
+        (projectResource project)
-            invites <- do
+        (ProjectR projectHash)
-                invites' <- getTopicInvites $ projectResource project
+        (ProjectCollabsR projectHash)
-                for invites' $ \ (inviter, recip, time, role) -> (,,,)
+        (ProjectRemoveR projectHash)
-                    <$> (getPersonWidgetInfo =<< bitraverse grabPerson pure inviter)
+        (ProjectInviteR projectHash)
-                    <*> getPersonWidgetInfo recip
+        (projectNavW (Entity projectID project) actor)
-                    <*> pure time
-                    <*> pure role
-            joins <- do
-                joins' <- getTopicJoins $ projectResource project
-                for joins' $ \ (recip, time, role) ->
-                    (,time,role) <$> getPersonWidgetInfo recip
-            return (project, actor, collabs, invites, joins)
-        $(widgetFile "project/collab/list")
-        where
-        grabPerson actorID = do
-            actorByKey <- getLocalActor actorID
-            case actorByKey of
-                LocalActorPerson personID -> return personID
-                _ -> error "Surprise, local inviter actor isn't a Person"
-
-getProjectInviteR :: KeyHashid Project -> Handler Html
-getProjectInviteR projectHash = do
-    projectID <- decodeKeyHashid404 projectHash
-    ((_result, widget), enctype) <- runFormPost $ projectInviteForm projectID
-    defaultLayout $(widgetFile "project/collab/new")
 
 postProjectInviteR :: KeyHashid Project -> Handler Html
 postProjectInviteR projectHash = do
     projectID <- decodeKeyHashid404 projectHash
-    ProjectInvite recipPersonID role <-
+    resourceID <- runDB $ projectResource <$> get404 projectID
-        runFormPostRedirect (ProjectInviteR projectHash) $ projectInviteForm projectID
+    serveInviteCollab resourceID (ProjectCollabsR projectHash)
-
-    personEntity@(Entity personID person) <- requireAuth
-    personHash <- encodeKeyHashid personID
-    recipPersonHash <- encodeKeyHashid recipPersonID
-    encodeRouteHome <- getEncodeRouteHome
-
-    result <- runExceptT $ do
-        (maybeSummary, audience, invite) <- do
-            let uRecipient = encodeRouteHome $ PersonR recipPersonHash
-                uResourceCollabs = encodeRouteHome $ ProjectCollabsR projectHash
-            C.invite personID uRecipient uResourceCollabs role
-        grantID <- do
-            maybeItem <- lift $ runDB $ do
-                resourceID <- projectResource <$> get404 projectID
-                getGrant resourceID personID
-            fromMaybeE maybeItem "You need to be a collaborator in the Project to invite people"
-        grantHash <- encodeKeyHashid grantID
-        let uCap = encodeRouteHome $ ProjectOutboxItemR projectHash grantHash
-        (localRecips, remoteRecips, fwdHosts, action) <-
-            C.makeServerInput (Just uCap) maybeSummary audience $ AP.InviteActivity invite
-        let cap =
-                Left (LocalActorProject projectID, LocalActorProject projectHash, grantID)
-        handleViaActor
-            personID (Just cap) localRecips remoteRecips fwdHosts action
-
-    case result of
-        Left e -> do
-            setMessage $ toHtml e
-            redirect $ ProjectInviteR projectHash
-        Right inviteID -> do
-            setMessage "Invite sent"
-            redirect $ ProjectCollabsR projectHash
 
 postProjectRemoveR :: KeyHashid Project -> CollabId -> Handler Html
 postProjectRemoveR projectHash collabID = do
     projectID <- decodeKeyHashid404 projectHash
-
+    resourceID <- runDB $ projectResource <$> get404 projectID
-    personEntity@(Entity personID person) <- requireAuth
+    serveRemoveCollab resourceID (ProjectCollabsR projectHash) collabID
-    personHash <- encodeKeyHashid personID
-    encodeRouteHome <- getEncodeRouteHome
-
-    result <- runExceptT $ do
-        mpidOrU <- lift $ runDB $ runMaybeT $ do
-            Collab _ resourceID <- MaybeT $ get collabID
-            j <- MaybeT $ get projectID
-            guard $ resourceID == projectResource j
-            _ <- MaybeT $ getBy $ UniqueCollabEnable collabID
-            member <-
-                Left <$> MaybeT (getValBy $ UniqueCollabRecipLocal collabID) <|>
-                Right <$> MaybeT (getValBy $ UniqueCollabRecipRemote collabID)
-            lift $
-                (resourceID,) <$>
-                bitraverse
-                    (pure . collabRecipLocalPerson)
-                    (getRemoteActorURI <=< getJust . collabRecipRemoteActor)
-                    member
-        (resourceID, pidOrU) <- maybe notFound pure mpidOrU
-        (maybeSummary, audience, remove) <- do
-            uRecipient <-
-                case pidOrU of
-                    Left pid -> encodeRouteHome . PersonR <$> encodeKeyHashid pid
-                    Right u -> pure u
-            let uResourceCollabs = encodeRouteHome $ ProjectCollabsR projectHash
-            C.remove personID uRecipient uResourceCollabs
-        grantID <- do
-            maybeItem <- lift $ runDB $ getGrant resourceID personID
-            fromMaybeE maybeItem "You need to be a collaborator in the Project to remove people"
-        grantHash <- encodeKeyHashid grantID
-        let uCap = encodeRouteHome $ ProjectOutboxItemR projectHash grantHash
-        (localRecips, remoteRecips, fwdHosts, action) <-
-            C.makeServerInput (Just uCap) maybeSummary audience $ AP.RemoveActivity remove
-        let cap =
-                Left (LocalActorProject projectID, LocalActorProject projectHash, grantID)
-        handleViaActor
-            personID (Just cap) localRecips remoteRecips fwdHosts action
-
-    case result of
-        Left e -> do
-            setMessage $ toHtml e
-        Right removeID ->
-            setMessage "Remove sent"
-    redirect $ ProjectCollabsR projectHash
 
 getProjectComponentsR :: KeyHashid Project -> Handler TypedContent
 getProjectComponentsR projectHash = do

src/Vervis/Handler/Repo.hs

@@ -189,6 +189,7 @@ import Vervis.Persist.Actor
 import Vervis.Persist.Collab
 import Vervis.Readme
 import Vervis.Recipient
+import Vervis.Serve.Collab
 import Vervis.Settings
 import Vervis.SourceTree
 import Vervis.Style

src/Vervis/Persist/Collab.hs

@@ -23,9 +23,9 @@ module Vervis.Persist.Collab
     , getStemAdd
     , getGrantRecip
     , getComponentE
-    , getTopicGrants
+    , getCollabs
-    , getTopicInvites
+    , getCollabInvites
-    , getTopicJoins
+    , getCollabJoins
 
     , verifyCapability
     , verifyCapability'
@@ -207,145 +207,270 @@ getComponentE (ComponentRepo k) e = ComponentRepo <$> getEntityE k e
 getComponentE (ComponentDeck k) e = ComponentDeck <$> getEntityE k e
 getComponentE (ComponentLoom k) e = ComponentLoom <$> getEntityE k e
 
-getTopicGrants
+getCollabs
     :: MonadIO m
     => ResourceId
-    -> ReaderT SqlBackend m [(AP.Role, Either PersonId RemoteActorId, CollabId, UTCTime)]
+    -> ReaderT SqlBackend m
-getTopicGrants resourceID =
+        [ ( AP.Role
-    fmap (reverse . sortOn (view _1) . map adapt) $
+          , UTCTime
-    E.select $ E.from $ \ (collab `E.InnerJoin` enable `E.InnerJoin` grant `E.LeftOuterJoin` recipL `E.LeftOuterJoin` recipR) -> do
+          , Either (Entity Person, Actor) (Instance, RemoteObject, RemoteActor)
-        E.on $ E.just (enable E.^. CollabEnableCollab) E.==. recipR E.?. CollabRecipRemoteCollab
+          , CollabId
-        E.on $ E.just (enable E.^. CollabEnableCollab) E.==. recipL E.?. CollabRecipLocalCollab
+          )
+        ]
+getCollabs resourceID =
+    fmap (sortOn $ view _2) $ liftA2 (++)
+        (map (\ (E.Value role, E.Value time, person, Entity _ actor, E.Value collabID) ->
+                (role, time, Left (person, actor), collabID)
+             )
+            <$> getLocals
+        )
+        (map (\ (E.Value role, E.Value time, Entity _ i, Entity _ ro, Entity _ ra, E.Value collabID) ->
+                (role, time, Right (i, ro, ra), collabID)
+             )
+            <$> getRemotes
+        )
+    where
+    getLocals =
+        E.select $ E.from $ \ (collab `E.InnerJoin` enable `E.InnerJoin` grant `E.InnerJoin` recip `E.InnerJoin` person `E.InnerJoin` actor) -> do
+            E.on $ person E.^. PersonActor E.==. actor E.^. ActorId
+            E.on $ recip E.^. CollabRecipLocalPerson E.==. person E.^. PersonId
+            E.on $ collab E.^. CollabId E.==. recip E.^. CollabRecipLocalCollab
             E.on $ enable E.^. CollabEnableGrant E.==. grant E.^. OutboxItemId
             E.on $ collab E.^. CollabId E.==. enable E.^. CollabEnableCollab
             E.where_ $ collab E.^. CollabTopic E.==. E.val resourceID
             E.orderBy [E.desc $ enable E.^. CollabEnableId]
             return
                 ( collab E.^. CollabRole
-            , recipL E.?. CollabRecipLocalPerson
-            , recipR E.?. CollabRecipRemoteActor
-            , collab E.^. CollabId
                 , grant E.^. OutboxItemPublished
+                , person
+                , actor
+                , collab E.^. CollabId
                 )
-    where
+    getRemotes =
-    adapt (E.Value role, E.Value maybePersonID, E.Value maybeRemoteActorID, E.Value ctID, E.Value time) =
+        E.select $ E.from $ \ (collab `E.InnerJoin` enable `E.InnerJoin` grant `E.InnerJoin` recip `E.InnerJoin` ra `E.InnerJoin` ro `E.InnerJoin` i) -> do
-        ( role
+            E.on $ ro E.^. RemoteObjectInstance E.==. i E.^. InstanceId
-        , case (maybePersonID, maybeRemoteActorID) of
+            E.on $ ra E.^. RemoteActorIdent E.==. ro E.^. RemoteObjectId
-            (Nothing, Nothing) -> error "No recip"
+            E.on $ recip E.^. CollabRecipRemoteActor E.==. ra E.^. RemoteActorId
-            (Just personID, Nothing) -> Left personID
+            E.on $ collab E.^. CollabId E.==. recip E.^. CollabRecipRemoteCollab
-            (Nothing, Just remoteActorID) -> Right remoteActorID
+            E.on $ enable E.^. CollabEnableGrant E.==. grant E.^. OutboxItemId
-            (Just _, Just _) -> error "Multi recip"
+            E.on $ collab E.^. CollabId E.==. enable E.^. CollabEnableCollab
-        , ctID
+            E.where_ $ collab E.^. CollabTopic E.==. E.val resourceID
-        , time
+            E.orderBy [E.desc $ enable E.^. CollabEnableId]
+            return
+                ( collab E.^. CollabRole
+                , grant E.^. OutboxItemPublished
+                , i
+                , ro
+                , ra
+                , collab E.^. CollabId
                 )
 
-getTopicInvites
+getCollabInvites
     :: MonadIO m
     => ResourceId
-    -> ReaderT SqlBackend m [(Either ActorId RemoteActorId, Either PersonId RemoteActorId, UTCTime, AP.Role)]
+    -> ReaderT SqlBackend m
-getTopicInvites resourceID =
+        [ ( AP.Role
-    fmap (map adapt) $
+          , UTCTime
-    E.select $ E.from $
+          , Either (Entity Person, Actor) (Instance, RemoteObject, RemoteActor)
-    \ (collab `E.LeftOuterJoin` enable `E.InnerJoin` fulfills
+          , Either (Entity Person, Actor) (Instance, RemoteObject, RemoteActor)
-      `E.LeftOuterJoin` recipL `E.LeftOuterJoin` recipR
+          , CollabId
-      `E.LeftOuterJoin` (inviterL `E.InnerJoin` item `E.InnerJoin` actor)
+          )
-      `E.LeftOuterJoin` (inviterR `E.InnerJoin` activity)
+        ]
-      ) -> do
+getCollabInvites resourceID = sortOn (view _2) . concat <$> sequence
-        E.on $ inviterR E.?. CollabInviterRemoteInvite E.==. activity E.?. RemoteActivityId
+    [ map
-        E.on $ E.just (fulfills E.^. CollabFulfillsInviteId) E.==. inviterR E.?. CollabInviterRemoteCollab
+        (\ (E.Value role, E.Value time, mperson_I, Entity _ actor_I, person, Entity _ actor, E.Value collabID) ->
-        E.on $ item E.?. OutboxItemOutbox E.==. actor E.?. ActorOutbox
+            let person_I = fromMaybe (error "getCollabInvites LL local inviter isn't a Person") mperson_I
-        E.on $ inviterL E.?. CollabInviterLocalInvite E.==. item E.?. OutboxItemId
+            in  (role, time, Left (person_I, actor_I), Left (person, actor), collabID)
-        E.on $ E.just (fulfills E.^. CollabFulfillsInviteId) E.==. inviterL E.?. CollabInviterLocalCollab
+        )
-        E.on $ E.just (fulfills E.^. CollabFulfillsInviteCollab) E.==. recipR E.?. CollabRecipRemoteCollab
+        <$> getLL
-        E.on $ E.just (fulfills E.^. CollabFulfillsInviteCollab) E.==. recipL E.?. CollabRecipLocalCollab
+    , map
+        (\ (E.Value role, E.Value time, Entity _ iI, Entity _ roI, Entity _ raI, person, Entity _ actor, E.Value collabID) ->
+            (role, time, Right (iI, roI, raI), Left (person, actor), collabID)
+        )
+        <$> getLR
+    , map
+        (\ (E.Value role, E.Value time, mperson_I, Entity _ actor_I, Entity _ i, Entity _ ro, Entity _ ra, E.Value collabID) ->
+            let person_I = fromMaybe (error "getCollabInvites RL local inviter isn't a Person") mperson_I
+            in  (role, time, Left (person_I, actor_I), Right (i, ro, ra), collabID)
+        )
+        <$> getRL
+    , map
+        (\ (E.Value role, E.Value time, Entity _ iI, Entity _ roI, Entity _ raI, Entity _ i, Entity _ ro, Entity _ ra, E.Value collabID) ->
+            (role, time, Right (iI, roI, raI), Right (i, ro, ra), collabID)
+        )
+        <$> getRR
+    ]
+    where
+    getLL =
+        E.select $ E.from $ \ (collab `E.LeftOuterJoin` enable `E.InnerJoin` fulfills `E.InnerJoin` recip `E.InnerJoin` personR `E.InnerJoin` actorR `E.InnerJoin` inviter `E.InnerJoin` item `E.InnerJoin` actorI `E.LeftOuterJoin` personI) -> do
+            E.on $ E.just (actorI E.^. ActorId) E.==. personI E.?. PersonActor
+            E.on $ item E.^. OutboxItemOutbox E.==. actorI E.^. ActorOutbox
+            E.on $ inviter E.^. CollabInviterLocalInvite E.==. item E.^. OutboxItemId
+            E.on $ fulfills E.^. CollabFulfillsInviteId E.==. inviter E.^. CollabInviterLocalCollab
+            E.on $ personR E.^. PersonActor E.==. actorR E.^. ActorId
+            E.on $ recip E.^. CollabRecipLocalPerson E.==. personR E.^. PersonId
+            E.on $ collab E.^. CollabId E.==. recip E.^. CollabRecipLocalCollab
             E.on $ collab E.^. CollabId E.==. fulfills E.^. CollabFulfillsInviteCollab
             E.on $ E.just (collab E.^. CollabId) E.==. enable E.?. CollabEnableCollab
             E.where_ $
                 collab E.^. CollabTopic E.==. E.val resourceID E.&&.
                 E.isNothing (enable E.?. CollabEnableId)
-        E.orderBy [E.asc $ fulfills E.^. CollabFulfillsInviteId]
+            E.orderBy [E.desc $ collab E.^. CollabId]
             return
-            ( actor E.?. ActorId
+                ( collab E.^. CollabRole
-            , item E.?. OutboxItemPublished
+                , item E.^. OutboxItemPublished
-            , inviterR E.?. CollabInviterRemoteActor
+                , personI
-            , activity E.?. RemoteActivityReceived
+                , actorI
-            , recipL E.?. CollabRecipLocalPerson
+                , personR
-            , recipR E.?. CollabRecipRemoteActor
+                , actorR
-            , collab E.^. CollabRole
+                , collab E.^. CollabId
                 )
-    where
+    getLR =
-    adapt (E.Value inviterL, E.Value timeL, E.Value inviterR, E.Value timeR, E.Value recipL, E.Value recipR, E.Value role) =
+        E.select $ E.from $ \ (collab `E.LeftOuterJoin` enable `E.InnerJoin` fulfills `E.InnerJoin` recip `E.InnerJoin` personR `E.InnerJoin` actorR `E.InnerJoin` inviter `E.InnerJoin` activity `E.InnerJoin` raI `E.InnerJoin` roI `E.InnerJoin` iI) -> do
-        let l = case (inviterL, timeL) of
+            E.on $ roI E.^. RemoteObjectInstance E.==. iI E.^. InstanceId
-                    (Nothing, Nothing) -> Nothing
+            E.on $ raI E.^. RemoteActorIdent E.==. roI E.^. RemoteObjectId
-                    (Just i, Just t) -> Just (i, t)
+            E.on $ inviter E.^. CollabInviterRemoteActor E.==. raI E.^. RemoteActorId
-                    _ -> error "Impossible"
+            E.on $ inviter E.^. CollabInviterRemoteInvite E.==. activity E.^. RemoteActivityId
-            r = case (inviterR, timeR) of
+            E.on $ fulfills E.^. CollabFulfillsInviteId E.==. inviter E.^. CollabInviterRemoteCollab
-                    (Nothing, Nothing) -> Nothing
+            E.on $ personR E.^. PersonActor E.==. actorR E.^. ActorId
-                    (Just i, Just t) -> Just (i, t)
+            E.on $ recip E.^. CollabRecipLocalPerson E.==. personR E.^. PersonId
-                    _ -> error "Impossible"
+            E.on $ collab E.^. CollabId E.==. recip E.^. CollabRecipLocalCollab
-            (inviter, time) =
+            E.on $ collab E.^. CollabId E.==. fulfills E.^. CollabFulfillsInviteCollab
-                case (l, r) of
+            E.on $ E.just (collab E.^. CollabId) E.==. enable E.?. CollabEnableCollab
-                    (Nothing, Nothing) -> error "No inviter"
+            E.where_ $
-                    (Just (actorID, time), Nothing) ->
+                collab E.^. CollabTopic E.==. E.val resourceID E.&&.
-                        (Left actorID, time)
+                E.isNothing (enable E.?. CollabEnableId)
-                    (Nothing, Just (remoteActorID, time)) ->
+            E.orderBy [E.desc $ collab E.^. CollabId]
-                        (Right remoteActorID, time)
+            return
-                    (Just _, Just _) -> error "Multi inviter"
+                ( collab E.^. CollabRole
-        in  ( inviter
+                , activity E.^. RemoteActivityReceived
-            , case (recipL, recipR) of
+                , iI
-                (Nothing, Nothing) -> error "No recip"
+                , roI
-                (Just personID, Nothing) -> Left personID
+                , raI
-                (Nothing, Just remoteActorID) -> Right remoteActorID
+                , personR
-                (Just _, Just _) -> error "Multi recip"
+                , actorR
-            , time
+                , collab E.^. CollabId
-            , role
+                )
+    getRL =
+        E.select $ E.from $ \ (collab `E.LeftOuterJoin` enable `E.InnerJoin` fulfills `E.InnerJoin` recip `E.InnerJoin` ra `E.InnerJoin` ro `E.InnerJoin` i `E.InnerJoin` inviter `E.InnerJoin` item `E.InnerJoin` actorI `E.LeftOuterJoin` personI) -> do
+            E.on $ E.just (actorI E.^. ActorId) E.==. personI E.?. PersonActor
+            E.on $ item E.^. OutboxItemOutbox E.==. actorI E.^. ActorOutbox
+            E.on $ inviter E.^. CollabInviterLocalInvite E.==. item E.^. OutboxItemId
+            E.on $ fulfills E.^. CollabFulfillsInviteId E.==. inviter E.^. CollabInviterLocalCollab
+            E.on $ ro E.^. RemoteObjectInstance E.==. i E.^. InstanceId
+            E.on $ ra E.^. RemoteActorIdent E.==. ro E.^. RemoteObjectId
+            E.on $ recip E.^. CollabRecipRemoteActor E.==. ra E.^. RemoteActorId
+            E.on $ collab E.^. CollabId E.==. recip E.^. CollabRecipRemoteCollab
+            E.on $ collab E.^. CollabId E.==. fulfills E.^. CollabFulfillsInviteCollab
+            E.on $ E.just (collab E.^. CollabId) E.==. enable E.?. CollabEnableCollab
+            E.where_ $
+                collab E.^. CollabTopic E.==. E.val resourceID E.&&.
+                E.isNothing (enable E.?. CollabEnableId)
+            E.orderBy [E.desc $ collab E.^. CollabId]
+            return
+                ( collab E.^. CollabRole
+                , item E.^. OutboxItemPublished
+                , personI
+                , actorI
+                , i
+                , ro
+                , ra
+                , collab E.^. CollabId
+                )
+    getRR =
+        E.select $ E.from $ \ (collab `E.LeftOuterJoin` enable `E.InnerJoin` fulfills `E.InnerJoin` recip `E.InnerJoin` ra `E.InnerJoin` ro `E.InnerJoin` i `E.InnerJoin` inviter `E.InnerJoin` activity `E.InnerJoin` raI `E.InnerJoin` roI `E.InnerJoin` iI) -> do
+            E.on $ roI E.^. RemoteObjectInstance E.==. iI E.^. InstanceId
+            E.on $ raI E.^. RemoteActorIdent E.==. roI E.^. RemoteObjectId
+            E.on $ inviter E.^. CollabInviterRemoteActor E.==. raI E.^. RemoteActorId
+            E.on $ inviter E.^. CollabInviterRemoteInvite E.==. activity E.^. RemoteActivityId
+            E.on $ fulfills E.^. CollabFulfillsInviteId E.==. inviter E.^. CollabInviterRemoteCollab
+            E.on $ ro E.^. RemoteObjectInstance E.==. i E.^. InstanceId
+            E.on $ ra E.^. RemoteActorIdent E.==. ro E.^. RemoteObjectId
+            E.on $ recip E.^. CollabRecipRemoteActor E.==. ra E.^. RemoteActorId
+            E.on $ collab E.^. CollabId E.==. recip E.^. CollabRecipRemoteCollab
+            E.on $ collab E.^. CollabId E.==. fulfills E.^. CollabFulfillsInviteCollab
+            E.on $ E.just (collab E.^. CollabId) E.==. enable E.?. CollabEnableCollab
+            E.where_ $
+                collab E.^. CollabTopic E.==. E.val resourceID E.&&.
+                E.isNothing (enable E.?. CollabEnableId)
+            E.orderBy [E.desc $ collab E.^. CollabId]
+            return
+                ( collab E.^. CollabRole
+                , activity E.^. RemoteActivityReceived
+                , iI
+                , roI
+                , raI
+                , i
+                , ro
+                , ra
+                , collab E.^. CollabId
                 )
 
-getTopicJoins
+getCollabJoins
     :: MonadIO m
     => ResourceId
-    -> ReaderT SqlBackend m [(Either PersonId RemoteActorId, UTCTime, AP.Role)]
+    -> ReaderT SqlBackend m
-getTopicJoins resourceID =
+        [ ( AP.Role
-    fmap (map adapt) $
+          , UTCTime
-    E.select $ E.from $
+          , Either (Entity Person, Actor) (Instance, RemoteObject, RemoteActor)
-    \ (collab `E.LeftOuterJoin` enable `E.InnerJoin` fulfills
+          , CollabId
-      `E.LeftOuterJoin` (joinL `E.InnerJoin` recipL `E.InnerJoin` item)
+          )
-      `E.LeftOuterJoin` (joinR `E.InnerJoin` recipR `E.InnerJoin` activity)
+        ]
-      ) -> do
+getCollabJoins resourceID =
-        E.on $ joinR E.?. CollabRecipRemoteJoinJoin E.==. activity E.?. RemoteActivityId
+    fmap (sortOn $ view _2) $ liftA2 (++)
-        E.on $ joinR E.?. CollabRecipRemoteJoinCollab E.==. recipR E.?. CollabRecipRemoteId
+        (map (\ (E.Value role, E.Value time, person, Entity _ actor, E.Value collabID) ->
-        E.on $ E.just (fulfills E.^. CollabFulfillsJoinId) E.==. joinR E.?. CollabRecipRemoteJoinFulfills
+                (role, time, Left (person, actor), collabID)
-        E.on $ joinL E.?. CollabRecipLocalJoinJoin E.==. item E.?. OutboxItemId
+             )
-        E.on $ joinL E.?. CollabRecipLocalJoinCollab E.==. recipL E.?. CollabRecipLocalId
+            <$> getLocals
-        E.on $ E.just (fulfills E.^. CollabFulfillsJoinId) E.==. joinL E.?. CollabRecipLocalJoinFulfills
+        )
+        (map (\ (E.Value role, E.Value time, Entity _ i, Entity _ ro, Entity _ ra, E.Value collabID) ->
+                (role, time, Right (i, ro, ra), collabID)
+             )
+            <$> getRemotes
+        )
+    where
+    getLocals =
+        E.select $ E.from $ \ (collab `E.LeftOuterJoin` enable `E.InnerJoin` fulfills `E.InnerJoin` join `E.InnerJoin` recip `E.InnerJoin` person `E.InnerJoin` actor `E.InnerJoin` item) -> do
+            E.on $ join E.^. CollabRecipLocalJoinJoin E.==. item E.^. OutboxItemId
+            E.on $ person E.^. PersonActor E.==. actor E.^. ActorId
+            E.on $ recip E.^. CollabRecipLocalPerson E.==. person E.^. PersonId
+            E.on $ join E.^. CollabRecipLocalJoinCollab E.==. recip E.^. CollabRecipLocalId
+            E.on $ fulfills E.^. CollabFulfillsJoinId E.==. join E.^. CollabRecipLocalJoinFulfills
             E.on $ collab E.^. CollabId E.==. fulfills E.^. CollabFulfillsJoinCollab
             E.on $ E.just (collab E.^. CollabId) E.==. enable E.?. CollabEnableCollab
             E.where_ $
                 collab E.^. CollabTopic E.==. E.val resourceID E.&&.
                 E.isNothing (enable E.?. CollabEnableId)
-        E.orderBy [E.asc $ fulfills E.^. CollabFulfillsJoinId]
+            E.orderBy [E.desc $ collab E.^. CollabId]
             return
-            ( recipL E.?. CollabRecipLocalPerson
+                ( collab E.^. CollabRole
-            , item E.?. OutboxItemPublished
+                , item E.^. OutboxItemPublished
-            , recipR E.?. CollabRecipRemoteActor
+                , person
-            , activity E.?. RemoteActivityReceived
+                , actor
-            , collab E.^. CollabRole
+                , collab E.^. CollabId
+                )
+    getRemotes =
+        E.select $ E.from $ \ (collab `E.LeftOuterJoin` enable `E.InnerJoin` fulfills `E.InnerJoin` join `E.InnerJoin` recip `E.InnerJoin` ra `E.InnerJoin` ro `E.InnerJoin` i `E.InnerJoin` activity) -> do
+            E.on $ join E.^. CollabRecipRemoteJoinJoin E.==. activity E.^. RemoteActivityId
+            E.on $ ro E.^. RemoteObjectInstance E.==. i E.^. InstanceId
+            E.on $ ra E.^. RemoteActorIdent E.==. ro E.^. RemoteObjectId
+            E.on $ recip E.^. CollabRecipRemoteActor E.==. ra E.^. RemoteActorId
+            E.on $ join E.^. CollabRecipRemoteJoinCollab E.==. recip E.^. CollabRecipRemoteId
+            E.on $ fulfills E.^. CollabFulfillsJoinId E.==. join E.^. CollabRecipRemoteJoinFulfills
+            E.on $ collab E.^. CollabId E.==. fulfills E.^. CollabFulfillsJoinCollab
+            E.on $ E.just (collab E.^. CollabId) E.==. enable E.?. CollabEnableCollab
+            E.where_ $
+                collab E.^. CollabTopic E.==. E.val resourceID E.&&.
+                E.isNothing (enable E.?. CollabEnableId)
+            E.orderBy [E.desc $ collab E.^. CollabId]
+            return
+                ( collab E.^. CollabRole
+                , activity E.^. RemoteActivityReceived
+                , i
+                , ro
+                , ra
+                , collab E.^. CollabId
                 )
-    where
-    adapt (E.Value recipL, E.Value timeL, E.Value recipR, E.Value timeR, E.Value role) =
-        let l = case (recipL, timeL) of
-                    (Nothing, Nothing) -> Nothing
-                    (Just r, Just t) -> Just (r, t)
-                    _ -> error "Impossible"
-            r = case (recipR, timeR) of
-                    (Nothing, Nothing) -> Nothing
-                    (Just r, Just t) -> Just (r, t)
-                    _ -> error "Impossible"
-        in  case (l, r) of
-                (Nothing, Nothing) -> error "No recip"
-                (Just (personID, time), Nothing) -> (Left personID, time, role)
-                (Nothing, Just (remoteActorID, time)) -> (Right remoteActorID, time, role)
-                (Just _, Just _) -> error "Multi recip"
 
 verifyCapability
     :: MonadIO m

src/Vervis/Serve/Collab.hs

@@ -0,0 +1,255 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2023, 2024 by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ Copying is an act of love. Please copy, reuse and share.
+ -
+ - The author(s) have dedicated all copyright and related and neighboring
+ - rights to this software to the public domain worldwide. This software is
+ - distributed without any warranty.
+ -
+ - You should have received a copy of the CC0 Public Domain Dedication along
+ - with this software. If not, see
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+module Vervis.Serve.Collab
+    ( serveTeamsCollection
+    , serveCollabs
+    , serveInviteCollab
+    , serveRemoveCollab
+    )
+where
+
+import Control.Applicative
+import Control.Exception.Base
+import Control.Monad
+import Control.Monad.Trans.Except
+import Control.Monad.Trans.Maybe
+import Data.Aeson
+import Data.Bifunctor
+import Data.Bitraversable
+import Data.ByteString (ByteString)
+import Data.Default.Class
+import Data.Foldable
+import Data.Maybe (fromMaybe, isJust)
+import Data.Text (Text)
+import Data.Time.Clock
+import Data.Traversable
+import Database.Persist
+import Network.HTTP.Client hiding (Proxy, proxy)
+import Network.HTTP.Types.Method
+import Network.HTTP.Types.Status
+import Optics.Core
+import Text.Blaze.Html (Html)
+import Yesod.Auth
+import Yesod.Core
+import Yesod.Core.Handler (redirect, setMessage, lookupPostParam, notFound)
+import Yesod.Form.Functions (runFormPost, runFormGet)
+import Yesod.Form.Types (FormResult (..))
+import Yesod.Persist.Core (runDB, get404, getBy404)
+
+import qualified Data.ByteString.Lazy as BL
+import qualified Data.Text as T
+import qualified Database.Esqueleto as E
+
+import Control.Concurrent.Actor
+import Database.Persist.JSON
+import Development.PatchMediaType
+import Network.FedURI
+import Web.ActivityPub hiding (Project (..), Repo (..), Actor (..), ActorDetail (..), ActorLocal (..))
+import Yesod.ActivityPub
+import Yesod.FedURI
+import Yesod.Hashids
+import Yesod.MonadSite
+
+import qualified Web.ActivityPub as AP
+
+import Control.Monad.Trans.Except.Local
+import Data.Either.Local
+import Data.Paginate.Local
+import Database.Persist.Local
+import Yesod.Form.Local
+import Yesod.Persist.Local
+
+import Vervis.Actor
+import Vervis.Actor2
+import Vervis.API
+import Vervis.Data.Actor
+import Vervis.Data.Collab
+import Vervis.FedURI
+import Vervis.Form.Tracker
+import Vervis.Foundation
+import Vervis.Model
+import Vervis.Persist.Actor
+import Vervis.Persist.Collab
+import Vervis.Settings
+import Vervis.Ticket
+import Vervis.TicketFilter
+import Vervis.Time
+import Vervis.Widget.Tracker
+
+import qualified Vervis.Client as C
+import qualified Vervis.Recipient as VR
+
+serveTeamsCollection meR hereR resourceID = do
+    teams <- runDB $ getResourceTeams resourceID
+    h <- asksSite siteInstanceHost
+    encodeRouteLocal <- getEncodeRouteLocal
+    encodeRouteHome <- getEncodeRouteHome
+    hashGroup <- getEncodeKeyHashid
+    let makeItem (role, time, team, _) = AP.Relationship
+            { AP.relationshipId           = Nothing
+            , AP.relationshipExtraTypes   = []
+            , AP.relationshipSubject      = encodeRouteHome meR
+            , AP.relationshipProperty     = Left AP.RelHasRecCollab
+            , AP.relationshipObject       =
+                case team of
+                    Left (groupID, _) ->
+                        encodeRouteHome $ GroupR $ hashGroup groupID
+                    Right (i, ro, _) ->
+                        ObjURI (instanceHost i) (remoteObjectIdent ro)
+            , AP.relationshipAttributedTo = encodeRouteLocal meR
+            , AP.relationshipPublished    = Just time
+            , AP.relationshipUpdated      = Nothing
+            , AP.relationshipInstrument   = Just role
+            }
+        teamsAP = AP.Collection
+            { AP.collectionId         = encodeRouteLocal hereR
+            , AP.collectionType       = CollectionTypeUnordered
+            , AP.collectionTotalItems = Just $ length teams
+            , AP.collectionCurrent    = Nothing
+            , AP.collectionFirst      = Nothing
+            , AP.collectionLast       = Nothing
+            , AP.collectionItems      = map (Doc h . makeItem) teams
+            , AP.collectionContext    = Just $ encodeRouteLocal meR
+            }
+    provideHtmlAndAP teamsAP $ redirectToPrettyJSON hereR
+
+serveCollabs
+    :: AP.RelationshipProperty
+    -> ResourceId
+    -> Route App
+    -> Route App
+    -> (CollabId -> Route App)
+    -> Route App
+    -> Widget
+    -> Handler TypedContent
+serveCollabs rel resourceID meR hereR removeR inviteR navW = do
+    collabs <- runDB $ getCollabs resourceID
+    h <- asksSite siteInstanceHost
+    encodeRouteLocal <- getEncodeRouteLocal
+    encodeRouteHome <- getEncodeRouteHome
+    hashPerson <- getEncodeKeyHashid
+    let makeItem (role, time, collab, _) = AP.Relationship
+            { AP.relationshipId           = Nothing
+            , AP.relationshipExtraTypes   = []
+            , AP.relationshipSubject      = encodeRouteHome meR
+            , AP.relationshipProperty     = Left rel
+            , AP.relationshipObject       =
+                case collab of
+                    Left (Entity personID _, _) ->
+                        encodeRouteHome $ PersonR $ hashPerson personID
+                    Right (i, ro, _) ->
+                        ObjURI (instanceHost i) (remoteObjectIdent ro)
+            , AP.relationshipAttributedTo = encodeRouteLocal meR
+            , AP.relationshipPublished    = Just time
+            , AP.relationshipUpdated      = Nothing
+            , AP.relationshipInstrument   = Just role
+            }
+        collabsAP = AP.Collection
+            { AP.collectionId         = encodeRouteLocal hereR
+            , AP.collectionType       = CollectionTypeUnordered
+            , AP.collectionTotalItems = Just $ length collabs
+            , AP.collectionCurrent    = Nothing
+            , AP.collectionFirst      = Nothing
+            , AP.collectionLast       = Nothing
+            , AP.collectionItems      = map (Doc h . makeItem) collabs
+            , AP.collectionContext    = Just $ encodeRouteLocal meR
+            }
+    provideHtmlAndAP collabsAP $ getHtml collabs
+    where
+    getHtml collabs = do
+        mp <- maybeAuthId
+        haveAdmin <- fmap isJust $ handlerToWidget $ runDB $ runMaybeT $ do
+            personID <- MaybeT $ pure mp
+            MaybeT $ getCapability personID (Left resourceID) AP.RoleAdmin
+        (invites, joins) <- handlerToWidget $ runDB $ do
+            invites <- getCollabInvites resourceID
+            joins <- getCollabJoins resourceID
+            return (invites, joins)
+        [whamlet|
+            ^{navW}
+            ^{collabsW haveAdmin collabs invites joins removeR inviteR}
+        |]
+
+serveInviteCollab :: ResourceId -> Route App -> Handler Html
+serveInviteCollab resourceID collabsR = do
+    (uRecipient, role) <- runFormPostRedirect collabsR inviteForm
+
+    personEntity@(Entity personID person) <- requireAuth
+    personHash <- encodeKeyHashid personID
+    encodeRouteHome <- getEncodeRouteHome
+
+    result <- runExceptT $ do
+        (maybeSummary, audience, invite) <- do
+            let uResourceCollabs = encodeRouteHome collabsR
+            C.invite personID uRecipient uResourceCollabs role
+        cap <- do
+            maybeItem <-
+                lift $ runDB $
+                    getCapability personID (Left resourceID) AP.RoleAdmin
+            fromMaybeE maybeItem "You need admin access to the resource to invite people"
+        uCap <- lift $ renderActivityURI cap
+        (localRecips, remoteRecips, fwdHosts, action) <-
+            C.makeServerInput (Just uCap) maybeSummary audience $ AP.InviteActivity invite
+        let cap' = first (\ (la, i) -> (la, error "lah", i)) cap
+        handleViaActor
+            personID (Just cap') localRecips remoteRecips fwdHosts action
+
+    case result of
+        Left e -> setMessage $ toHtml e
+        Right _inviteID -> setMessage "Invite sent"
+    redirect collabsR
+
+serveRemoveCollab :: ResourceId -> Route App -> CollabId -> Handler Html
+serveRemoveCollab resourceID collabsR collabID = do
+    personEntity@(Entity personID person) <- requireAuth
+    personHash <- encodeKeyHashid personID
+    encodeRouteHome <- getEncodeRouteHome
+
+    result <- runExceptT $ do
+        mpidOrU <- lift $ runDB $ runMaybeT $ do
+            Collab _ resourceID' <- MaybeT $ get collabID
+            guard $ resourceID' == resourceID
+            _ <- MaybeT $ getBy $ UniqueCollabEnable collabID
+            member <-
+                Left <$> MaybeT (getValBy $ UniqueCollabRecipLocal collabID) <|>
+                Right <$> MaybeT (getValBy $ UniqueCollabRecipRemote collabID)
+            lift $
+                bitraverse
+                    (pure . collabRecipLocalPerson)
+                    (getRemoteActorURI <=< getJust . collabRecipRemoteActor)
+                    member
+        pidOrU <- maybe notFound pure mpidOrU
+        (maybeSummary, audience, remove) <- do
+            uRecipient <-
+                case pidOrU of
+                    Left pid -> encodeRouteHome . PersonR <$> encodeKeyHashid pid
+                    Right u -> pure u
+            let uResourceCollabs = encodeRouteHome collabsR
+            C.remove personID uRecipient uResourceCollabs
+        cap <- do
+            maybeItem <- lift $ runDB $ getCapability personID (Left resourceID) AP.RoleAdmin
+            fromMaybeE maybeItem "You need to have admin access to the resource to remove collaborators"
+        uCap <- lift $ renderActivityURI cap
+        (localRecips, remoteRecips, fwdHosts, action) <-
+            C.makeServerInput (Just uCap) maybeSummary audience $ AP.RemoveActivity remove
+        let cap' = first (\ (la, i) -> (la, error "lah", i)) cap
+        handleViaActor
+            personID (Just cap') localRecips remoteRecips fwdHosts action
+
+    case result of
+        Left e -> setMessage $ toHtml e
+        Right _removeID -> setMessage "Remove sent"
+    redirect collabsR

src/Vervis/Web/Collab.hs

@@ -16,7 +16,6 @@
 module Vervis.Web.Collab
     ( verifyCapability''
     , checkCapabilityBeforeExtending
-    , serveTeamsCollection
     )
 where
 
@@ -519,37 +518,3 @@ checkCapabilityBeforeExtending uCap extender = do
                 AP.grantAllows grant == AP.Distribute &&
                 targetIsTeam &&
                 (AP.grantAllows h == AP.Distribute || AP.grantAllows h == AP.Invoke)
-
-serveTeamsCollection meR hereR resourceID = do
-    teams <- runDB $ getResourceTeams resourceID
-    h <- asksSite siteInstanceHost
-    encodeRouteLocal <- YF.getEncodeRouteLocal
-    encodeRouteHome <- YF.getEncodeRouteHome
-    hashGroup <- getEncodeKeyHashid
-    let makeItem (role, time, team, _) = AP.Relationship
-            { AP.relationshipId           = Nothing
-            , AP.relationshipExtraTypes   = []
-            , AP.relationshipSubject      = encodeRouteHome meR
-            , AP.relationshipProperty     = Left AP.RelHasRecCollab
-            , AP.relationshipObject       =
-                case team of
-                    Left (groupID, _) ->
-                        encodeRouteHome $ GroupR $ hashGroup groupID
-                    Right (i, ro, _) ->
-                        ObjURI (instanceHost i) (remoteObjectIdent ro)
-            , AP.relationshipAttributedTo = encodeRouteLocal meR
-            , AP.relationshipPublished    = Just time
-            , AP.relationshipUpdated      = Nothing
-            , AP.relationshipInstrument   = Just role
-            }
-        teamsAP = AP.Collection
-            { AP.collectionId         = encodeRouteLocal hereR
-            , AP.collectionType       = CollectionTypeUnordered
-            , AP.collectionTotalItems = Just $ length teams
-            , AP.collectionCurrent    = Nothing
-            , AP.collectionFirst      = Nothing
-            , AP.collectionLast       = Nothing
-            , AP.collectionItems      = map (Doc h . makeItem) teams
-            , AP.collectionContext    = Just $ encodeRouteLocal meR
-            }
-    provideHtmlAndAP teamsAP $ redirectToPrettyJSON hereR

src/Vervis/Widget/Tracker.hs

@@ -23,13 +23,17 @@ module Vervis.Widget.Tracker
     , actorLinkFedW
     , groupNavW
     , personPermitsForResourceW
+    , collabsW
     )
 where
 
 import Data.Bifunctor
+import Data.Time.Clock
 import Database.Persist
 import Database.Persist.Types
+import Network.HTTP.Types.Method
 import Yesod.Core.Widget
+import Yesod.Form
 import Yesod.Persist.Core
 
 import Network.FedURI
@@ -44,10 +48,14 @@ import Vervis.Actor
 import Vervis.Data.Actor
 import Vervis.Data.Collab
 import Vervis.FedURI
+import Vervis.Form.Tracker
 import Vervis.Foundation
 import Vervis.Model
 import Vervis.Model.Ident
 import Vervis.Settings
+import Vervis.Time
+import Vervis.Widget
+import Vervis.Widget.Person
 
 import qualified Vervis.Recipient as VR
 
@@ -215,3 +223,31 @@ personPermitsForResourceW permits = do
                 \ via #
                 [ ^{actorLinkFedW via} ]
     |]
+
+collabsW
+    :: Bool
+    -> [ ( AP.Role
+         , UTCTime
+         , Either (Entity Person, Actor) (Instance, RemoteObject, RemoteActor)
+         , CollabId
+         )
+       ]
+    -> [ ( AP.Role
+         , UTCTime
+         , Either (Entity Person, Actor) (Instance, RemoteObject, RemoteActor)
+         , Either (Entity Person, Actor) (Instance, RemoteObject, RemoteActor)
+         , CollabId
+         )
+       ]
+    -> [ ( AP.Role
+         , UTCTime
+         , Either (Entity Person, Actor) (Instance, RemoteObject, RemoteActor)
+         , CollabId
+         )
+       ]
+    -> (CollabId -> Route App)
+    -> Route App
+    -> Widget
+collabsW haveAdmin collabs invites joins removeR inviteR = do
+    ((_, widgetIC), enctypeIC) <- handlerToWidget $ runFormPost inviteForm
+    $(widgetFile "widget/collabs")

templates/deck/collab/list.hamlet

@@ -1,6 +1,7 @@
 $# This file is part of Vervis.
 $#
-$# Written in 2016, 2019, 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
+$# Written in 2016, 2019, 2022, 2023, 2024
+$# by fr33domlover <fr33domlover@riseup.net>.
 $#
 $# ♡ Copying is an act of love. Please copy, reuse and share.
 $#
@@ -14,46 +15,4 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
 
 ^{deckNavW (Entity deckID deck) actor}
 
-<h2>Collaborators
+^{collabsW haveAdmin collabs invites joins (DeckRemoveR deckHash) (DeckInvite deckHash)}
-
-<table>
-  <tr>
-    <th>Role
-    <th>Collaborator
-    <th>Since
-  $forall (person, role, ctID, since) <- collabs
-    <tr>
-      <td>#{show role}
-      <td>^{personLinkFedW person}
-      <td>#{showDate since}
-      <td>^{buttonW POST "Remove" (DeckRemoveR deckHash 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=@{DeckInviteR deckHash}>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}

templates/deck/collab/new.hamlet

@@ -1,18 +0,0 @@
-$# This file is part of Vervis.
-$#
-$# Written in 2016, 2023 by fr33domlover <fr33domlover@riseup.net>.
-$#
-$# ♡ Copying is an act of love. Please copy, reuse and share.
-$#
-$# The author(s) have dedicated all copyright and related and neighboring
-$# rights to this software to the public domain worldwide. This software is
-$# distributed without any warranty.
-$#
-$# You should have received a copy of the CC0 Public Domain Dedication along
-$# with this software. If not, see
-$# <http://creativecommons.org/publicdomain/zero/1.0/>.
-
-<form method=POST action=@{DeckInviteR deckHash} enctype=#{enctype}>
-  ^{widget}
-  <div class="submit">
-    <input type="submit">

templates/group/members.hamlet

@@ -1,59 +0,0 @@
-$# This file is part of Vervis.
-$#
-$# Written in 2016, 2019, 2023 by fr33domlover <fr33domlover@riseup.net>.
-$#
-$# ♡ Copying is an act of love. Please copy, reuse and share.
-$#
-$# The author(s) have dedicated all copyright and related and neighboring
-$# rights to this software to the public domain worldwide. This software is
-$# distributed without any warranty.
-$#
-$# You should have received a copy of the CC0 Public Domain Dedication along
-$# with this software. If not, see
-$# <http://creativecommons.org/publicdomain/zero/1.0/>.
-
-^{groupNavW (Entity groupID group) actor}
-
-<h2>Members
-
-<table>
-  <tr>
-    <th>Role
-    <th>Member
-    <th>Since
-  $forall (person, role, ctID, since) <- members
-    <tr>
-      <td>#{show role}
-      <td>^{personLinkFedW person}
-      <td>#{showDate since}
-      <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=@{GroupInviteR groupHash}>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}

templates/widget/collabs.hamlet

@@ -1,6 +1,7 @@
 $# This file is part of Vervis.
 $#
-$# Written in 2016, 2019, 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
+$# Written in 2016, 2019, 2022, 2023, 2024
+$# by fr33domlover <fr33domlover@riseup.net>.
 $#
 $# ♡ Copying is an act of love. Please copy, reuse and share.
 $#
@@ -12,48 +13,53 @@ $# You should have received a copy of the CC0 Public Domain Dedication along
 $# with this software. If not, see
 $# <http://creativecommons.org/publicdomain/zero/1.0/>.
 
-^{projectNavW (Entity projectID project) actor}
-
 <h2>Collaborators
 
 <table>
   <tr>
     <th>Role
-    <th>Collaborator
     <th>Since
-  $forall (person, role, ctID, since) <- collabs
+    <th>Collaborator
+    $if haveAdmin
+      <th>Remove
+  $forall (role, since, person, collabID) <- collabs
     <tr>
       <td>#{show role}
-      <td>^{personLinkFedW person}
       <td>#{showDate since}
-      <td>^{buttonW POST "Remove" (ProjectRemoveR projectHash ctID)}
+      <td>^{personLinkFedW person}
+      $if haveAdmin
+        <td>^{buttonW POST "Remove" (removeR collabID)}
+
+$if haveAdmin
+  <p>Invite a collaborator:
+  <form method=POST action=@{inviteR} enctype=#{enctypeIC}>
+    ^{widgetIC}
+    <input type=submit>
 
 <h2>Invites
 
 <table>
   <tr>
     <th>Inviter
-    <th>Invitee
     <th>Role
     <th>Time
-  $forall (inviter, invitee, time, role) <- invites
+    <th>Collaborator
+  $forall (role, time, inviter, invitee, _collabID) <- invites
     <tr>
       <td>^{personLinkFedW inviter}
-      <td>^{personLinkFedW invitee}
       <td>#{show role}
       <td>#{showDate time}
-
+      <td>^{personLinkFedW invitee}
-<a href=@{ProjectInviteR projectHash}>Invite…
 
 <h2>Joins
 
 <table>
   <tr>
-    <th>Joiner
     <th>Role
     <th>Time
-  $forall (joiner, time, role) <- joins
+    <th>Collaborator
+  $forall (role, time, person, _collabID) <- joins
     <tr>
-      <td>^{personLinkFedW joiner}
       <td>#{show role}
       <td>#{showDate time}
+      <td>^{personLinkFedW person}

th/routes

@@ -180,7 +180,7 @@
 /groups/#GroupKeyHashid/stamps/#SigKeyKeyHashid         GroupStampR      GET
 
 /groups/#GroupKeyHashid/members                         GroupMembersR    GET
-/groups/#GroupKeyHashid/invite                          GroupInviteR     GET POST
+/groups/#GroupKeyHashid/invite                          GroupInviteR     POST
 /groups/#GroupKeyHashid/remove/#CollabId                GroupRemoveR     POST
 
 /groups/#GroupKeyHashid/members/#CollabEnableKeyHashid/live GroupMemberLiveR GET
@@ -257,13 +257,11 @@
 /new-deck                                         DeckNewR        GET POST
 /decks/#DeckKeyHashid/delete                      DeckDeleteR     POST
 /decks/#DeckKeyHashid/edit                        DeckEditR       GET POST
-/decks/#DeckKeyHashid/follow                      DeckFollowR     POST
-/decks/#DeckKeyHashid/unfollow                    DeckUnfollowR   POST
 
 /decks/#DeckKeyHashid/stamps/#SigKeyKeyHashid     DeckStampR      GET
 
 /decks/#DeckKeyHashid/collabs                     DeckCollabsR    GET
-/decks/#DeckKeyHashid/invite                      DeckInviteR     GET POST
+/decks/#DeckKeyHashid/invite                      DeckInviteR     POST
 /decks/#DeckKeyHashid/remove/#CollabId            DeckRemoveR     POST
 /decks/#DeckKeyHashid/projects                    DeckProjectsR   GET
 
@@ -387,7 +385,7 @@
 /projects/#ProjectKeyHashid/stamps/#SigKeyKeyHashid      ProjectStampR      GET
 
 /projects/#ProjectKeyHashid/collabs                      ProjectCollabsR    GET
-/projects/#ProjectKeyHashid/invite                       ProjectInviteR     GET POST
+/projects/#ProjectKeyHashid/invite                       ProjectInviteR     POST
 /projects/#ProjectKeyHashid/remove/#CollabId             ProjectRemoveR     POST
 
 /projects/#ProjectKeyHashid/components                   ProjectComponentsR GET

vervis.cabal

@@ -249,6 +249,9 @@ library
                        Vervis.RemoteActorStore.Types
                        --Vervis.Repo
                        Vervis.Secure
+
+                       Vervis.Serve.Collab
+
                        Vervis.Settings
                        Vervis.Settings.StaticFiles
                        Vervis.Settings.TH