From cc135692c07ea05af566472812b7cb6d4f03afd6 Mon Sep 17 00:00:00 2001
From: Pere Lev <pere@towards.vision>
Date: Tue, 30 May 2023 14:34:37 +0300
Subject: [PATCH] Web.ActivityPub: Add Grant 'allows' & 'delegates' fields

---
 src/Vervis/API.hs               |  8 ++++++++
 src/Vervis/Data/Collab.hs       |  8 +++++++-
 src/Vervis/Federation/Collab.hs |  2 ++
 src/Web/ActivityPub.hs          | 27 ++++++++++++++++++++++++++-
 4 files changed, 43 insertions(+), 2 deletions(-)

diff --git a/src/Vervis/API.hs b/src/Vervis/API.hs
index 273fcaa..7e01b1e 100644
--- a/src/Vervis/API.hs
+++ b/src/Vervis/API.hs
@@ -368,6 +368,8 @@ acceptC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips re
                     , grantResult  = Nothing
                     , grantStart   = Nothing
                     , grantEnd     = Nothing
+                    , grantAllows  = Invoke
+                    , grantDelegates = Nothing
                     }
                 }
 
@@ -1156,6 +1158,8 @@ createPatchTrackerC (Entity pidUser personUser) senderActor maybeCap localRecips
                 , grantResult  = Nothing
                 , grantStart   = Nothing
                 , grantEnd     = Nothing
+                , grantAllows  = Invoke
+                , grantDelegates = Nothing
                 }
             }
 
@@ -1384,6 +1388,8 @@ createRepositoryC (Entity pidUser personUser) senderActor maybeCap localRecips r
                 , grantResult    = Nothing
                 , grantStart   = Nothing
                 , grantEnd     = Nothing
+                , grantAllows  = Invoke
+                , grantDelegates = Nothing
                 }
             }
 
@@ -1638,6 +1644,8 @@ createTicketTrackerC (Entity pidUser personUser) senderActor maybeCap localRecip
                 , grantResult    = Nothing
                 , grantStart   = Nothing
                 , grantEnd     = Nothing
+                , grantAllows  = Invoke
+                , grantDelegates = Nothing
                 }
             }
 
diff --git a/src/Vervis/Data/Collab.hs b/src/Vervis/Data/Collab.hs
index 963b775..859f221 100644
--- a/src/Vervis/Data/Collab.hs
+++ b/src/Vervis/Data/Collab.hs
@@ -166,8 +166,14 @@ parseGrant
         , Maybe UTCTime
         , Maybe UTCTime
         )
-parseGrant h (AP.Grant object context target mresult mstart mend) = do
+parseGrant h (AP.Grant object context target mresult mstart mend allows deleg) = do
     verifyRole object
+    case allows of
+        AP.Invoke -> pure ()
+        _ -> throwE "Grant.allows isn't invoke"
+    case deleg of
+        Nothing -> pure ()
+        Just _ -> throwE "Grant.delegates is specified"
     (,,,,)
         <$> parseContext context
         <*> parseTarget target
diff --git a/src/Vervis/Federation/Collab.hs b/src/Vervis/Federation/Collab.hs
index a0cb05b..a5f9170 100644
--- a/src/Vervis/Federation/Collab.hs
+++ b/src/Vervis/Federation/Collab.hs
@@ -554,6 +554,8 @@ topicAcceptF topicActor topicResource now recipHash author body mfwd luAccept ac
                     , AP.grantResult    = Nothing
                     , AP.grantStart   = Nothing
                     , AP.grantEnd     = Nothing
+                    , AP.grantAllows  = AP.Invoke
+                    , AP.grantDelegates = Nothing
                     }
                 }
 
diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs
index 2a85b1b..f6abd0c 100644
--- a/src/Web/ActivityPub.hs
+++ b/src/Web/ActivityPub.hs
@@ -63,6 +63,7 @@ module Web.ActivityPub
     , Branch (..)
     , Role (..)
     , Duration (..)
+    , Usage (..)
 
       -- * Activity
     , Accept (..)
@@ -1548,6 +1549,24 @@ instance ToJSON Duration where
     toEncoding (Duration i) =
         toEncoding $ T.concat ["PT", T.pack $ show i, "S"]
 
+data Usage = GatherAndConvey | Distribute | Invoke deriving Eq
+
+instance FromJSON Usage where
+    parseJSON = withText "Usage" parse
+        where
+        parse "gatherAndConvey" = pure GatherAndConvey
+        parse "distribute"      = pure Distribute
+        parse "invoke"          = pure Invoke
+        parse t = fail $ "Unknown usage: " ++ T.unpack t
+
+instance ToJSON Usage where
+    toJSON = error "toJSON Usage"
+    toEncoding u =
+        toEncoding $ case u of
+            GatherAndConvey -> "gatherAndConvey" :: Text
+            Distribute -> "distribute"
+            Invoke -> "invoke"
+
 data Accept u = Accept
     { acceptObject :: ObjURI u
     , acceptResult :: Maybe LocalURI
@@ -1710,6 +1729,8 @@ data Grant u = Grant
     , grantResult   :: Maybe (LocalURI, Maybe Duration)
     , grantStart    :: Maybe UTCTime
     , grantEnd      :: Maybe UTCTime
+    , grantAllows   :: Usage
+    , grantDelegates :: Maybe (ObjURI u)
     }
 
 parseGrant :: UriMode u => Authority u -> Object -> Parser (Grant u)
@@ -1726,9 +1747,11 @@ parseGrant h o =
             )
         <*> o .:? "startTime"
         <*> o .:? "endTime"
+        <*> o .: "allows"
+        <*> o .:? "delegates"
 
 encodeGrant :: UriMode u => Authority u -> Grant u -> Series
-encodeGrant h (Grant obj context target mresult mstart mend)
+encodeGrant h (Grant obj context target mresult mstart mend allows mdelegates)
     =  "object"  .=+ obj
     <> "context" .= ObjURI h context
     <> "target"  .= target
@@ -1742,6 +1765,8 @@ encodeGrant h (Grant obj context target mresult mstart mend)
        )
     <> "startTime" .=? mstart
     <> "endTime"   .=? mend
+    <> "allows"    .=  allows
+    <> "delegates" .=? mdelegates
 
 data Invite u = Invite
     { inviteInstrument :: Either Role (ObjURI u)