Web.ActivityPub: Add grantResult field, with optional duration

src/Vervis/API.hs

@@ -336,6 +336,7 @@ acceptC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips re
             )
     prepareGrant recipHash sender topic = do
         encodeRouteHome <- getEncodeRouteHome
+        encodeRouteLocal <- getEncodeRouteLocal
 
         topicHash <-
             grantResourceLocalActor <$> hashGrantResource topic
@@ -362,8 +363,9 @@ acceptC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips re
                 , actionFulfills   = [AP.acceptObject accept]
                 , actionSpecific   = GrantActivity Grant
                     { grantObject  = Left RoleAdmin
-                    , grantContext = encodeRouteHome $ renderLocalActor topicHash
+                    , grantContext = encodeRouteLocal $ renderLocalActor topicHash
                     , grantTarget  = encodeRouteHome $ PersonR recipHash
+                    , grantResult  = Nothing
                     }
                 }
 
@@ -1133,6 +1135,7 @@ createPatchTrackerC (Entity pidUser personUser) senderActor maybeCap localRecips
 
     prepareGrant adminHash loomHash obiidCreate actors stages = do
         encodeRouteHome <- getEncodeRouteHome
+        encodeRouteLocal <- getEncodeRouteLocal
         obikhidCreate <- encodeKeyHashid obiidCreate
         let recips =
                 map encodeRouteHome $
@@ -1146,8 +1149,9 @@ createPatchTrackerC (Entity pidUser personUser) senderActor maybeCap localRecips
                 [encodeRouteHome $ PersonOutboxItemR adminHash obikhidCreate]
             , actionSpecific = GrantActivity Grant
                 { grantObject   = Left RoleAdmin
-                , grantContext  = encodeRouteHome $ LoomR loomHash
+                , grantContext  = encodeRouteLocal $ LoomR loomHash
                 , grantTarget   = encodeRouteHome $ PersonR adminHash
+                , grantResult  = Nothing
                 }
             }
 
@@ -1355,6 +1359,7 @@ createRepositoryC (Entity pidUser personUser) senderActor maybeCap localRecips r
 
     prepareGrant adminHash repoHash obiidCreate actors stages = do
         encodeRouteHome <- getEncodeRouteHome
+        encodeRouteLocal <- getEncodeRouteLocal
         obikhidCreate <- encodeKeyHashid obiidCreate
         let recips =
                 map encodeRouteHome $
@@ -1368,8 +1373,9 @@ createRepositoryC (Entity pidUser personUser) senderActor maybeCap localRecips r
                 [encodeRouteHome $ PersonOutboxItemR adminHash obikhidCreate]
             , actionSpecific   = GrantActivity Grant
                 { grantObject    = Left RoleAdmin
-                , grantContext   = encodeRouteHome $ RepoR repoHash
+                , grantContext   = encodeRouteLocal $ RepoR repoHash
                 , grantTarget    = encodeRouteHome $ PersonR adminHash
+                , grantResult    = Nothing
                 }
             }
 
@@ -1603,6 +1609,7 @@ createTicketTrackerC (Entity pidUser personUser) senderActor maybeCap localRecip
 
     prepareGrant adminHash deckHash obiidCreate actors stages = do
         encodeRouteHome <- getEncodeRouteHome
+        encodeRouteLocal <- getEncodeRouteLocal
         obikhidCreate <- encodeKeyHashid obiidCreate
         let recips =
                 map encodeRouteHome $
@@ -1616,8 +1623,9 @@ createTicketTrackerC (Entity pidUser personUser) senderActor maybeCap localRecip
                 [encodeRouteHome $ PersonOutboxItemR adminHash obikhidCreate]
             , actionSpecific   = GrantActivity Grant
                 { grantObject    = Left RoleAdmin
-                , grantContext   = encodeRouteHome $ DeckR deckHash
+                , grantContext   = encodeRouteLocal $ DeckR deckHash
                 , grantTarget    = encodeRouteHome $ PersonR adminHash
+                , grantResult    = Nothing
                 }
             }
 

src/Vervis/Actor/Person.hs

@@ -164,12 +164,12 @@ personGrant now recipPersonID author body mfwd luGrant grant = do
 
     -- Check input
     (_remoteResource, recipient) <- do
-        (resource, recip) <- parseGrant grant
         let u@(ObjURI h _) = remoteAuthorURI author
+        (resource, recip, _mresult) <- parseGrant h grant
         resourceURI <-
             case resource of
-                Right (ObjURI h' r) | h == h' -> return (u, r)
-                _ -> throwE "Grant resource and Grant author are from different instances"
+                Right r -> return (u, r)
+                _ -> error "Remote Grant but parseGrant identified local resource"
         when (recip == Right u) $
             throwE "Grant sender and target are the same remote actor"
         return (resourceURI, recip)

src/Vervis/Data/Collab.hs

@@ -156,20 +156,28 @@ parseJoin (AP.Join instrument object) = do
     nameExceptT "Join object" (parseTopic object)
 
 parseGrant
-    :: AP.Grant URIMode
+    :: Host
+    -> AP.Grant URIMode
     -> ActE
-        ( Either (GrantResourceBy Key) FedURI
+        ( Either (GrantResourceBy Key) LocalURI
         , Either (GrantRecipBy Key) FedURI
+        , Maybe (LocalURI, Maybe Int)
         )
-parseGrant (AP.Grant object context target) = do
+parseGrant h (AP.Grant object context target mresult) = do
     verifyRole object
-    (,) <$> parseContext context
+    (,,)
+        <$> parseContext context
         <*> parseTarget target
+        <*> pure
+                (fmap
+                    (\ (lu, md) -> (lu, (\ (AP.Duration i) -> i) <$> md))
+                    mresult
+                )
     where
     verifyRole (Left AP.RoleAdmin) = pure ()
     verifyRole (Right _) =
         throwE "ForgeFed Admin is the only role allowed currently"
-    parseContext u@(ObjURI h lu) = do
+    parseContext lu = do
         hl <- hostIsLocal h
         if hl
             then Left <$> do
@@ -184,7 +192,7 @@ parseGrant (AP.Grant object context target) = do
                 unhashGrantResourceE'
                     resourceHash
                     "Grant resource contains invalid hashid"
-            else pure $ Right u
+            else pure $ Right lu
         where
         parseGrantResource (RepoR r) = Just $ GrantResourceRepo r
         parseGrantResource (DeckR d) = Just $ GrantResourceDeck d

src/Vervis/Federation/Collab.hs

@@ -521,6 +521,7 @@ topicAcceptF topicActor topicResource now recipHash author body mfwd luAccept ac
 
     prepareGrant sender = do
         encodeRouteHome <- getEncodeRouteHome
+        encodeRouteLocal <- getEncodeRouteLocal
 
         accepter <- getJust $ remoteAuthorId author
         let topicByHash = grantResourceLocalActor $ topicResource recipHash
@@ -548,8 +549,9 @@ topicAcceptF topicActor topicResource now recipHash author body mfwd luAccept ac
                 , AP.actionFulfills   = [AP.acceptObject accept]
                 , AP.actionSpecific   = AP.GrantActivity AP.Grant
                     { AP.grantObject    = Left AP.RoleAdmin
-                    , AP.grantContext   = encodeRouteHome $ renderLocalActor topicByHash
+                    , AP.grantContext   = encodeRouteLocal $ renderLocalActor topicByHash
                     , AP.grantTarget    = remoteAuthorURI author
+                    , AP.grantResult    = Nothing
                     }
                 }
 

src/Web/ActivityPub.hs

@@ -14,6 +14,8 @@
  - <http://creativecommons.org/publicdomain/zero/1.0/>.
  -}
 
+{-# LANGUAGE StrictData #-}
+
 module Web.ActivityPub
     ( -- * Type-safe manipulation tools
       --
@@ -60,6 +62,7 @@ module Web.ActivityPub
     , Commit (..)
     , Branch (..)
     , Role (..)
+    , Duration (..)
 
       -- * Activity
     , Accept (..)
@@ -150,6 +153,7 @@ import Network.HTTP.Client.Conduit.ActivityPub (httpAPEither)
 import Network.HTTP.Simple (JSONException)
 import Network.HTTP.Types.Header (HeaderName, hContentType)
 import Text.Email.Parser (EmailAddress)
+import Text.Read (readMaybe)
 import Yesod.Core.Content (ContentType)
 import Yesod.Core.Handler (ProvidedRep, provideRepType)
 
@@ -1491,6 +1495,26 @@ instance ToJSON Role where
         toEncoding $ case r of
             RoleAdmin -> "https://forgefed.org/ns#admin" :: Text
 
+data Duration = Duration Int
+
+instance FromJSON Duration where
+    parseJSON = withText "Duration" parse
+        where
+        parse t =
+            case T.stripSuffix "S" =<< T.stripPrefix "PT" t of
+                Nothing -> fail $ "Not in PTS format: " ++ T.unpack t
+                Just t' ->
+                    case readMaybe $ T.unpack t' of
+                        Nothing -> fail $ "Not an Int: " ++ T.unpack t'
+                        Just n -> do
+                            guard $ n > 0
+                            return $ Duration n
+
+instance ToJSON Duration where
+    toJSON = error "toJSON Duration"
+    toEncoding (Duration i) =
+        toEncoding $ T.concat ["PT", T.pack $ show i, "S"]
+
 data Accept u = Accept
     { acceptObject :: ObjURI u
     , acceptResult :: Maybe LocalURI
@@ -1648,22 +1672,35 @@ encodeFollow (Follow obj mcontext hide)
 
 data Grant u = Grant
     { grantObject   :: Either Role (ObjURI u)
-    , grantContext  :: ObjURI u
+    , grantContext  :: LocalURI
     , grantTarget   :: ObjURI u
+    , grantResult   :: Maybe (LocalURI, Maybe Duration)
     }
 
-parseGrant :: UriMode u => Object -> Parser (Grant u)
-parseGrant o =
+parseGrant :: UriMode u => Authority u -> Object -> Parser (Grant u)
+parseGrant h o =
     Grant
         <$> o .:+ "object"
-        <*> o .: "context"
+        <*> withAuthorityO h (o .: "context")
         <*> o .: "target"
+        <*> do  mres <- o .:+? "result"
+                for mres $ \case
+                    Left u -> (,Nothing) <$> withAuthorityO h (pure u)
+                    Right r ->
+                        (,) <$> withAuthorityO h (r .: "id") <*> r .:? "duration"
 
-encodeGrant :: UriMode u => Grant u -> Series
-encodeGrant (Grant obj context target)
+encodeGrant :: UriMode u => Authority u -> Grant u -> Series
+encodeGrant h (Grant obj context target mresult)
     =  "object"  .=+ obj
-    <> "context" .= context
+    <> "context" .= ObjURI h context
     <> "target"  .= target
+    <> case mresult of
+        Nothing -> mempty
+        Just (result, mduration) ->
+            "result"  `pair` pairs
+                (  "id"       .=  ObjURI h result
+                <> "duration" .=? mduration
+                )
 
 data Invite u = Invite
     { inviteInstrument :: Either Role (ObjURI u)
@@ -1891,7 +1928,7 @@ instance ActivityPub Activity where
                         "Apply"   -> ApplyActivity   <$> parseApply o
                         "Create"  -> CreateActivity  <$> parseCreate o a actor
                         "Follow"  -> FollowActivity  <$> parseFollow o
-                        "Grant"   -> GrantActivity   <$> parseGrant o
+                        "Grant"   -> GrantActivity   <$> parseGrant a o
                         "Invite"  -> InviteActivity  <$> parseInvite o
                         "Join"    -> JoinActivity    <$> parseJoin o
                         "Offer"   -> OfferActivity   <$> parseOffer o a actor
@@ -1917,7 +1954,7 @@ instance ActivityPub Activity where
         encodeSpecific _ _ (ApplyActivity a)   = encodeApply a
         encodeSpecific _ _ (CreateActivity a)  = encodeCreate a
         encodeSpecific _ _ (FollowActivity a)  = encodeFollow a
-        encodeSpecific _ _ (GrantActivity a)   = encodeGrant a
+        encodeSpecific h _ (GrantActivity a)   = encodeGrant h a
         encodeSpecific _ _ (InviteActivity a)  = encodeInvite a
         encodeSpecific _ _ (JoinActivity a)    = encodeJoin a
         encodeSpecific h u (OfferActivity a)   = encodeOffer h u a