S2S: Add 'Add' activity, adds a new version of the patch bundle to a Ticket

src/Web/ActivityPub.hs

@@ -60,6 +60,8 @@ module Web.ActivityPub
 
       -- * Activity
     , Accept (..)
+    , AddObject (..)
+    , Add (..)
     , CreateObject (..)
     , Create (..)
     , Follow (..)
@@ -112,6 +114,7 @@ import Data.Aeson
 import Data.Aeson.Encoding (pair)
 import Data.Aeson.Types (Parser, typeMismatch, listEncoding)
 import Data.Bifunctor
+import Data.Bitraversable
 import Data.ByteString (ByteString)
 import Data.Char
 import Data.Foldable (for_)
@@ -651,6 +654,12 @@ withAuthorityP a m = do
         then return v
         else fail "URI authority mismatch"
 
+withAuthorityD a m = do
+    Doc a' v <- m
+    if a == a'
+        then return v
+        else fail "URI authority mismatch"
+
 withAuthorityMaybeT a m = do
     mu <- m
     for mu $ \ (a', v) ->
@@ -1291,6 +1300,40 @@ encodeAccept authority (Accept obj mresult)
     =  "object" .=  obj
     <> "result" .=? (ObjURI authority <$> mresult)
 
+data AddObject u = AddBundle (NonEmpty (Patch u))
+
+instance ActivityPub AddObject where
+    jsonldContext = error "jsonldContext AddObject"
+    parseObject o = do
+        (h, b) <- parseObject o
+        patches <-
+            case b of
+                BundleHosted _ _ -> fail "Patches specified as URIs"
+                BundleOffer mlocal pts -> do
+                    for_ mlocal $ \ _ -> fail "Bundle 'id' specified"
+                    return pts
+        return (h, AddBundle patches)
+    toSeries h (AddBundle ps) = toSeries h $ BundleOffer Nothing ps
+
+data Add u = Add
+    { addObject :: Either (ObjURI u) (AddObject u)
+    , addTarget :: ObjURI u
+    }
+
+parseAdd :: UriMode u => Object -> Authority u -> Parser (Add u)
+parseAdd o h = Add
+    <$> (bitraverse pure (withAuthorityD h . pure) =<<
+            toEither <$> o .: "object"
+        )
+    <*> o .: "target"
+
+encodeAdd :: UriMode u => Authority u -> Add u -> Series
+encodeAdd h (Add obj target)
+    =  case obj of
+        Left u -> "object" .= u
+        Right o -> "object" `pair` pairs (toSeries h o)
+    <> "target" .= target
+
 data CreateObject u = CreateNote (Note u) | CreateTicket (Ticket u)
 
 instance ActivityPub CreateObject where
@@ -1446,6 +1489,7 @@ encodeUndo a (Undo obj) = "object" .= obj
 
 data SpecificActivity u
     = AcceptActivity (Accept u)
+    | AddActivity     (Add u)
     | CreateActivity (Create u)
     | FollowActivity (Follow u)
     | OfferActivity  (Offer u)
@@ -1476,6 +1520,7 @@ instance ActivityPub Activity where
                     typ <- o .: "type"
                     case typ of
                         "Accept"  -> AcceptActivity  <$> parseAccept a o
+                        "Add"     -> AddActivity     <$> parseAdd o a
                         "Create"  -> CreateActivity  <$> parseCreate o a actor
                         "Follow"  -> FollowActivity  <$> parseFollow o
                         "Offer"   -> OfferActivity   <$> parseOffer o a actor
@@ -1496,6 +1541,7 @@ instance ActivityPub Activity where
         where
         activityType :: SpecificActivity u -> Text
         activityType (AcceptActivity _)  = "Accept"
+        activityType (AddActivity _)     = "Add"
         activityType (CreateActivity _)  = "Create"
         activityType (FollowActivity _)  = "Follow"
         activityType (OfferActivity _)   = "Offer"
@@ -1504,6 +1550,7 @@ instance ActivityPub Activity where
         activityType (ResolveActivity _) = "Resolve"
         activityType (UndoActivity _)    = "Undo"
         encodeSpecific h _ (AcceptActivity a)  = encodeAccept h a
+        encodeSpecific h _ (AddActivity a)     = encodeAdd h a
         encodeSpecific h u (CreateActivity a)  = encodeCreate h u a
         encodeSpecific _ _ (FollowActivity a)  = encodeFollow a
         encodeSpecific h u (OfferActivity a)   = encodeOffer h u a