S2S: Project: Remove: Implement child/parent mode

migrations/578_2024-04-03_source_remove.model

@@ -0,0 +1,6 @@
+SourceRemove
+    send     SourceUsSendDelegatorId
+    activity InboxItemId
+
+    UniqueSourceRemove         send
+    UniqueSourceRemoveActivity activity

src/Control/Monad/Trans/Except/Local.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2019, 2022 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2019, 2022, 2024 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -17,6 +17,7 @@ module Control.Monad.Trans.Except.Local
     ( fromMaybeE
     , verifyNothingE
     , nameExceptT
+    , verifySingleE
     )
 where
 
@@ -33,3 +34,9 @@ verifyNothingE (Just _) e = throwE e
 
 nameExceptT :: Functor m => Text -> ExceptT Text m a -> ExceptT Text m a
 nameExceptT title = withExceptT $ \ e -> title <> ": " <> e
+
+verifySingleE list none several =
+    case list of
+        [] -> throwE none
+        [x] -> pure x
+        _ -> throwE several

src/Vervis/Federation/Util.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2019, 2020, 2023 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2019, 2020, 2023, 2024 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -15,6 +15,7 @@
 
 module Vervis.Federation.Util
     ( insertToInbox
+    , insertToInbox'
     )
 where
 
@@ -38,6 +39,47 @@ import Vervis.Model
 
 -- | Insert an activity delivered to us into our inbox. Return its
 -- database ID if the activity wasn't already in our inbox.
+insertToInbox'
+    :: UTCTime
+    -> Either
+        (LocalActorBy Key, ActorId, OutboxItemId)
+        (RemoteAuthor, LocalURI, Maybe ByteString)
+    -> ActivityBody
+    -> InboxId
+    -> Bool
+    -> ActDB
+        (Maybe
+            ( InboxItemId
+            , Either
+                (LocalActorBy Key, ActorId, OutboxItemId)
+                (RemoteAuthor, LocalURI, RemoteActivityId)
+            )
+        )
+insertToInbox' now (Left a@(_, _, outboxItemID)) _body inboxID unread = do
+    inboxItemID <- insert $ InboxItem unread now
+    maybeItem <- insertUnique $ InboxItemLocal inboxID outboxItemID inboxItemID
+    case maybeItem of
+        Nothing -> do
+            delete inboxItemID
+            return Nothing
+        Just _ -> return $ Just (inboxItemID, Left a)
+insertToInbox' now (Right (author, luAct, _)) body inboxID unread = do
+    let iidAuthor = remoteAuthorInstance author
+    roid <-
+        either entityKey id <$> insertBy' (RemoteObject iidAuthor luAct)
+    ractid <- either entityKey id <$> insertBy' RemoteActivity
+        { remoteActivityIdent    = roid
+        , remoteActivityContent  = persistJSONFromBL $ actbBL body
+        , remoteActivityReceived = now
+        }
+    ibiid <- insert $ InboxItem unread now
+    mibrid <- insertUnique $ InboxItemRemote inboxID ractid ibiid
+    case mibrid of
+        Nothing -> do
+            delete ibiid
+            return Nothing
+        Just _ -> return $ Just (ibiid, Right (author, luAct, ractid))
+
 insertToInbox
     :: UTCTime
     -> Either
@@ -53,27 +95,5 @@ insertToInbox
                 (RemoteAuthor, LocalURI, RemoteActivityId)
             )
         )
-insertToInbox now (Left a@(_, _, outboxItemID)) _body inboxID unread = do
-    inboxItemID <- insert $ InboxItem unread now
-    maybeItem <- insertUnique $ InboxItemLocal inboxID outboxItemID inboxItemID
-    case maybeItem of
-        Nothing -> do
-            delete inboxItemID
-            return Nothing
-        Just _ -> return $ Just $ Left a
-insertToInbox now (Right (author, luAct, _)) body inboxID unread = do
-    let iidAuthor = remoteAuthorInstance author
-    roid <-
-        either entityKey id <$> insertBy' (RemoteObject iidAuthor luAct)
-    ractid <- either entityKey id <$> insertBy' RemoteActivity
-        { remoteActivityIdent    = roid
-        , remoteActivityContent  = persistJSONFromBL $ actbBL body
-        , remoteActivityReceived = now
-        }
-    ibiid <- insert $ InboxItem unread now
-    mibrid <- insertUnique $ InboxItemRemote inboxID ractid ibiid
-    case mibrid of
-        Nothing -> do
-            delete ibiid
-            return Nothing
-        Just _ -> return $ Just $ Right (author, luAct, ractid)
+insertToInbox now act body inbox unread =
+    fmap snd <$> insertToInbox' now act body inbox unread

src/Vervis/Migration.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2016, 2018, 2019, 2020, 2021, 2022, 2023
+ - Written in 2016, 2018, 2019, 2020, 2021, 2022, 2023, 2024
  - by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
@@ -3212,6 +3212,8 @@ changes hLocal ctx =
     , addUnique' "SourceThemDelegateRemote" "" ["source", "grant"]
       -- 577
     , addEntities model_577_component_gather
+      -- 578
+    , addEntities model_578_source_remove
     ]
 
 migrateDB

src/Vervis/Migration/Entities.hs

@@ -69,6 +69,7 @@ module Vervis.Migration.Entities
     , model_564_permit
     , model_570_source_dest
     , model_577_component_gather
+    , model_578_source_remove
     )
 where
 
@@ -268,3 +269,6 @@ model_570_source_dest = $(schema "570_2023-12-09_source_dest")
 
 model_577_component_gather :: [Entity SqlBackend]
 model_577_component_gather = $(schema "577_2024-03-13_component_gather")
+
+model_578_source_remove :: [Entity SqlBackend]
+model_578_source_remove = $(schema "578_2024-04-03_source_remove")

th/models

@@ -1510,6 +1510,18 @@ SourceUsLeafToRemote
 
     UniqueSourceUsLeafToRemote leaf
 
+-------------------------------- Source remove -------------------------------
+
+-- Witnesses there's a removal request from the child's side, and I'm waiting
+-- for the child project/team to Accept, which is when I'll do the removal on
+-- my side
+
+SourceRemove
+    send     SourceUsSendDelegatorId
+    activity InboxItemId
+
+    UniqueSourceRemove activity
+
 ------------------------------------------------------------------------------
 -- Inheritance - Giver tracking her receivers
 -- (Project tracking its parents)