Web.ActivityPub: Add grantResult field, with optional duration

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