UI in deck collaborators list, for adding a new collaborator

src/Vervis/Form/Tracker.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2016, 2019, 2022 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2016, 2019, 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -18,6 +18,8 @@ module Vervis.Form.Tracker
     , newDeckForm
     , NewLoom (..)
     , newLoomForm
+    , DeckInvite (..)
+    , deckInviteForm
     --, NewProjectCollab (..)
     --, newProjectCollabForm
     --, editProjectForm
@@ -27,7 +29,7 @@ where
 import Data.Bifunctor
 import Data.Maybe
 import Data.Text (Text)
-import Database.Persist ((==.))
+import Database.Persist
 import Yesod.Form.Fields
 import Yesod.Form.Functions
 import Yesod.Form.Types
@@ -38,8 +40,11 @@ import qualified Database.Esqueleto as E
 
 import Yesod.Hashids
 
+import qualified Web.ActivityPub as AP
+
 import Vervis.Foundation
 import Vervis.Model
+import Vervis.Model.Ident
 
 data NewDeck = NewDeck
     { ndName  :: Text
@@ -78,36 +83,39 @@ newLoomForm = renderDivs $ NewLoom
             , repoID
             )
 
-{-
-data NewProjectCollab = NewProjectCollab
-    { ncPerson :: PersonId
-    , ncRole   :: Maybe RoleId
+data DeckInvite = DeckInvite
+    { diPerson :: PersonId
+    , diRole   :: AP.Role
     }
 
-newProjectCollabAForm
-    :: SharerId -> ProjectId -> AForm Handler NewProjectCollab
-newProjectCollabAForm sid jid = NewProjectCollab
+deckInviteForm :: DeckId -> Form DeckInvite
+deckInviteForm deckID = renderDivs $ DeckInvite
     <$> areq selectPerson "Person*" Nothing
-    <*> aopt selectRole   "Custom role" Nothing
+    <*> areq selectRole   "Role*"   Nothing
     where
     selectPerson = selectField $ do
         l <- runDB $ E.select $
-            E.from $ \ (person `E.InnerJoin` sharer `E.LeftOuterJoin` (recip `E.InnerJoin` topic)) -> do
-                E.on $ recip E.^. CollabRecipLocalCollab E.==. topic E.^. CollabTopicLocalProjectCollab E.&&.
-                       topic E.^. CollabTopicLocalProjectProject E.==. E.val jid
+            E.from $ \ (person `E.InnerJoin` actor `E.LeftOuterJoin` (recip `E.InnerJoin` topic)) -> do
+                E.on $ recip E.^. CollabRecipLocalCollab E.==. topic E.^. CollabTopicDeckCollab E.&&.
+                       topic E.^. CollabTopicDeckDeck E.==. E.val deckID
                 E.on $ person E.^. PersonId E.==. recip E.^. CollabRecipLocalPerson
-                E.on $ person E.^. PersonIdent E.==. sharer E.^. SharerId
+                E.on $ person E.^. PersonActor E.==. actor E.^. ActorId
                 E.where_ $ E.isNothing $ E.just $ recip E.^. CollabRecipLocalId
-                return (sharer E.^. SharerIdent, person E.^. PersonId)
-        optionsPairs $ map (bimap (shr2text . E.unValue) E.unValue) l
-    selectRole =
-        selectField $
-        optionsPersistKey [RoleSharer ==. sid] [] $
-        rl2text . roleIdent
-
-newProjectCollabForm :: SharerId -> ProjectId -> Form NewProjectCollab
-newProjectCollabForm sid jid = renderDivs $ newProjectCollabAForm sid jid
+                return (person, actor)
+        optionsPairs $
+            map (\ (Entity pid p, Entity _ a) ->
+                    ( T.concat
+                        [ actorName a
+                        , " ~"
+                        , username2text $ personUsername p
+                        ]
+                    , pid
+                    )
+                )
+            l
+    selectRole = selectField optionsEnum
 
+{-
 editProjectAForm :: SharerId -> Entity Project -> AForm Handler Project
 editProjectAForm sid (Entity jid project) = Project
     <$> pure                         (projectActor project)

src/Vervis/Foundation.hs

@@ -929,6 +929,8 @@ instance YesodBreadcrumbs App where
 
         DeckCollabsR d -> ("Collaborators", Just $ DeckR d)
 
+        DeckInviteR d  -> ("Invite", Just $ DeckR d)
+
         TicketR d t            -> ("#" <> keyHashidText t, Just $ DeckTicketsR d)
         TicketDiscussionR d t  -> ("Discussion", Just $ TicketR d t)
         TicketEventsR d t      -> ("Events", Just $ TicketR d t)

src/Vervis/Handler/Deck.hs

@@ -37,6 +37,8 @@ module Vervis.Handler.Deck
     , getDeckStampR
 
     , getDeckCollabsR
+    , getDeckInviteR
+    , postDeckInviteR
 
 
 
@@ -427,6 +429,48 @@ getDeckCollabsR deckHash = do
             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 AP.RoleAdmin <-
+        runFormPostRedirect (DeckInviteR deckHash) $ deckInviteForm deckID
+
+    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
+                uResource = encodeRouteHome $ DeckR deckHash
+            C.invite personID uRecipient uResource
+        grantID <- do
+            maybeItem <- lift $ runDB $ getGrant CollabTopicDeckCollab CollabTopicDeckDeck deckID recipPersonID
+            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
+
 
 
 

src/Vervis/Persist/Collab.hs

@@ -23,6 +23,8 @@ module Vervis.Persist.Collab
 
     , verifyCapability
     , verifyCapability'
+
+    , getGrant
     )
 where
 
@@ -312,3 +314,29 @@ verifyCapability' cap actor resource = do
                 LocalActorPerson personID -> return personID
                 _ -> throwE "Non-person local actors can't get Grants at the moment"
         processRemote (author, _, _) = pure $ remoteAuthorId author
+
+getGrant
+    :: ( MonadIO m
+       , PersistRecordBackend topic SqlBackend
+       , PersistRecordBackend resource SqlBackend
+       , Show (Key resource)
+       )
+    => EntityField topic CollabId
+    -> EntityField topic (Key resource)
+    -> Key resource
+    -> PersonId
+    -> ReaderT SqlBackend m (Maybe OutboxItemId)
+getGrant topicCollabField topicActorField resourceID personID = do
+    items <-
+        E.select $ E.from $ \ (topic `E.InnerJoin` enable `E.InnerJoin` grant `E.InnerJoin` recipL) -> do
+            E.on $ enable E.^. CollabEnableCollab E.==. recipL E.^. CollabRecipLocalCollab
+            E.on $ enable E.^. CollabEnableGrant E.==. grant E.^. OutboxItemId
+            E.on $ topic E.^. topicCollabField E.==. enable E.^. CollabEnableCollab
+            E.where_ $
+                topic E.^. topicActorField E.==. E.val resourceID E.&&.
+                recipL E.^. CollabRecipLocalPerson E.==. E.val personID
+            return $ grant E.^. OutboxItemId
+    case items of
+        [] -> return Nothing
+        [E.Value i] -> return $ Just i
+        _ -> error $ "Multiple grants for a Person in resource#" ++ show resourceID

src/Web/ActivityPub.hs

@@ -1517,7 +1517,7 @@ instance ActivityPub Branch where
         <> "ref"     .= ref
         <> "context" .= ObjURI authority repo
 
-data Role = RoleAdmin deriving Eq
+data Role = RoleAdmin deriving (Show, Eq, Enum, Bounded)
 
 instance FromJSON Role where
     parseJSON = withText "Role" parse

templates/deck/collab/list.hamlet

@@ -1,6 +1,6 @@
 $# This file is part of Vervis.
 $#
-$# Written in 2016, 2019, 2022 by fr33domlover <fr33domlover@riseup.net>.
+$# Written in 2016, 2019, 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
 $#
 $# ♡ Copying is an act of love. Please copy, reuse and share.
 $#
@@ -42,6 +42,8 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
       <td>Admin
       <td>#{showDate time}
 
+<a href=@{DeckInviteR deckHash}>Invite…
+
 <h2>Joins
 
 <table>
@@ -54,5 +56,3 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
       <td>^{personLinkFedW joiner}
       <td>Admin
       <td>#{showDate time}
-
-$# <a href=@{ProjectDevNewR shr prj}>Add…

templates/deck/collab/new.hamlet

@@ -1,6 +1,6 @@
 $# 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.
 $#
@@ -12,7 +12,7 @@ $# 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=@{ProjectDevsR shr rp} enctype=#{enctype}>
+<form method=POST action=@{DeckInviteR deckHash} enctype=#{enctype}>
   ^{widget}
   <div class="submit">
     <input type="submit">

th/routes

@@ -218,6 +218,7 @@
 /decks/#DeckKeyHashid/stamps/#SigKeyKeyHashid     DeckStampR      GET
 
 /decks/#DeckKeyHashid/collabs                     DeckCollabsR    GET
+/decks/#DeckKeyHashid/invite                      DeckInviteR     GET POST
 
 ---- Ticket ------------------------------------------------------------------