S2S: Loom: Port Offer{MR} handler from old federation code

This is to allow getting rid of the old C2S offerTicketC and write a C2S
Offer handler in the new actor system.

And that is to allow ticket opening and closing to work, so that it can
use delegated OCAPs too, as a first demo of delegated OCAPs in action.

src/Vervis/API.hs

@@ -18,7 +18,7 @@
 
 module Vervis.API
     ( handleViaActor
-    , acceptC
+    --, acceptC
     --, addBundleC
     , applyC
     --, noteC
@@ -188,6 +188,7 @@ verifyRemoteAddressed remoteRecips u =
         lus <- lookup h remoteRecips
         guard $ lu `elem` lus
 
+{-
 acceptC
     :: Entity Person
     -> Actor
@@ -203,8 +204,6 @@ acceptC
     -> AP.Accept URIMode
     -> ExceptT Text Handler OutboxItemId
 acceptC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips remoteRecips fwdHosts action accept = do
-    error "acceptC temporarily disabled due to actor refactoring"
-{-
     -- Check input
     verifyNothingE maybeCap "Capability not needed"
     acceptee <- parseAccept accept
@@ -1922,7 +1921,7 @@ offerTicketC (Entity senderPersonID senderPerson) senderActor maybeCap localReci
     lift $ forkWorker "offerTicketC: async HTTP Offer delivery" deliverHttpOffer
     for_ maybeAcceptMaybePull $ \ (deliverHttpAccept, maybePull) -> do
         lift $ forkWorker "offerTicketC: async HTTP Accept delivery" deliverHttpAccept
-        traverse generatePatches maybePull
+        VA2.runActE $ traverse generatePatches maybePull
 
     return offerID
 

src/Vervis/Actor/Loom.hs

@@ -18,23 +18,40 @@ module Vervis.Actor.Loom
     )
 where
 
+import Control.Applicative
+import Control.Exception.Base
 import Control.Monad
 import Control.Monad.IO.Class
 import Control.Monad.Logger.CallStack
 import Control.Monad.Trans.Class
 import Control.Monad.Trans.Except
 import Control.Monad.Trans.Maybe
+import Control.Monad.Trans.Reader
+import Data.Align
+import Data.Bifunctor
+import Data.Bitraversable
 import Data.ByteString (ByteString)
 import Data.Foldable
+import Data.List.NonEmpty (NonEmpty (..))
+import Data.Maybe
 import Data.Text (Text)
+import Data.These
 import Data.Time.Clock
+import Data.Traversable
 import Database.Persist
+import Database.Persist.Sql
+import Optics.Core
 import Yesod.Persist.Core
 
+import qualified Data.List.NonEmpty as NE
 import qualified Data.Text as T
+import qualified Database.Esqueleto as E
 
 import Control.Concurrent.Actor
+import Development.PatchMediaType
 import Network.FedURI
+import Web.Actor
+import Web.Actor.Persist
 import Yesod.MonadSite
 
 import qualified Web.ActivityPub as AP
@@ -42,19 +59,360 @@ import qualified Web.ActivityPub as AP
 import Control.Monad.Trans.Except.Local
 import Database.Persist.Local
 
+import Vervis.Access
+import Vervis.ActivityPub
 import Vervis.Actor
+import Vervis.Actor.Common
+import Vervis.Actor2
 import Vervis.Cloth
+import Vervis.Data.Actor
+import Vervis.Data.Collab
 import Vervis.Data.Discussion
+import Vervis.Data.Ticket
 import Vervis.FedURI
 import Vervis.Federation.Util
+import Vervis.Fetch
 import Vervis.Foundation
-import Vervis.Model
+import Vervis.Model hiding (deckCreate)
+import Vervis.Recipient (makeRecipientSet, LocalStageBy (..), Aud (..), collectAudience, localActorFollowers)
+import Vervis.Persist.Actor
+import Vervis.Persist.Collab
 import Vervis.Persist.Discussion
+import Vervis.RemoteActorStore
 import Vervis.Ticket
+import Vervis.Web.Repo
+
+-- Meaning: An actor A is offering a ticket or a ticket dependency
+-- Behavior:
+--      * Verify I'm the target
+--      * Insert the Offer to my inbox
+--      * Create the new ticket in my DB
+--      * Forward the Offer to my followers
+--      * Publish an Accept to:
+--          - My followers
+--          - Offer sender+followers
+loomOffer
+    :: UTCTime
+    -> LoomId
+    -> Verse
+    -> AP.Offer URIMode
+    -> ActE (Text, Act (), Next)
+loomOffer now loomID (Verse authorIdMsig body) (AP.Offer object uTarget) = do
+
+    -- Check input
+    (title, desc, source, originTipOrBundle, targetRepoID, maybeTargetBranch) <- do
+        ticket <-
+            case object of
+                AP.OfferTicket t -> pure t
+                _ -> throwE "Unsupported Offer.object type"
+        ObjURI hAuthor _ <- lift $ getActorURI authorIdMsig
+        let author = bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig
+        WorkItemOffer {..} <- checkOfferTicket hAuthor ticket uTarget
+        unless (bimap LocalActorPerson id wioAuthor == author) $
+            throwE "Offering a Ticket attributed to someone else"
+        Merge maybeOriginTip maybeBundle targetTip <- case wioRest of
+            TAM_Task _ ->
+                throwE
+                    "Offer target is some local deck, so I have no use for \
+                    \this Offer. Was I supposed to receive it?"
+            TAM_Merge loomID' merge ->
+                if loomID' == loomID
+                    then return merge
+                    else throwE
+                            "Offer target is some other local loom, so I have \
+                            \no use for this Offer. Was I supposed to receive \
+                            \it?"
+            TAM_Remote _ _ ->
+                throwE
+                    "Offer target is some remote tracker, so I have no use \
+                    \for this Offer. Was I supposed to receive it?"
+        originTipOrBundle <-
+            fromMaybeE
+                (align maybeOriginTip maybeBundle)
+                "MR provides neither origin nor patches"
+        (targetRepoID, maybeTargetBranch) <-
+            case targetTip of
+                TipLocalRepo repoID -> pure (repoID, Nothing)
+                TipLocalBranch repoID branch -> pure (repoID, Just branch)
+                _ -> throwE "MR target is a remote repo (this tracker serves only local repos)"
+        return (wioTitle, wioDesc, wioSource, originTipOrBundle, targetRepoID, maybeTargetBranch)
+
+    -- Verify the capability URI, if provided, is one of:
+    --   * Outbox item URI of a local actor, i.e. a local activity
+    --   * A remote URI
+    maybeCapability <-
+        for (AP.activityCapability $ actbActivity body) $ \ uCap ->
+            nameExceptT "Offer.capability" $
+                first (\ (actor, _, item) -> (actor, item)) <$>
+                    parseActivityURI' uCap
+
+    -- If origin repo is remote, HTTP GET its AP representation and
+    -- remember it in our DB
+    --
+    -- Why do we need to HTTP GET it? Because:
+    --      * No support for providing a signed repo object directly in the
+    --        Offer activity
+    --      * It may be nice to make sure a remote origin repo's VCS type
+    --        matches the target repo's VCS, even if patches are provided too
+    --          + However there's no support for caching VCS type when
+    --            remembering remote repo in our DB, so we'd have to check this
+    --            every time
+    --      * If origin is remote and no patches are provided, we'll need to
+    --        know the clone URL to generate the patches ourselves
+    --          + However the code here, for some simplicity, doesn't have a
+    --            way to skip that and do the whole handler synchronously in
+    --            case patches are provided or the origin is a local repo
+    --          + And no support for caching the clone URI in DB when
+    --            remembering the remote repo, so we'd need to do this every
+    --            time
+    let originTipOrBundle' =
+            bimap
+                (\case
+                    TipLocalRepo repoID -> Left (repoID, Nothing)
+                    TipLocalBranch repoID branch -> Left (repoID, Just branch)
+                    TipRemote uOrigin -> Right (uOrigin, Nothing)
+                    TipRemoteBranch uRepo branch -> Right (uRepo, Just branch)
+                )
+                id
+                originTipOrBundle
+    originTipOrBundle'' <-
+        bitraverse
+            (bitraverse
+                pure
+                (\ (uOrigin, maybeOriginBranch) -> do
+                    case maybeOriginBranch of
+                        Nothing -> do
+                            (vcs, raid, uClone, mb) <- withExceptT (T.pack . show) $ httpGetRemoteTip' uOrigin
+                            return (vcs, (raid, uClone, first Just <$> mb))
+                        Just branch -> do
+                            (vcs, raid, uClone) <- withExceptT (T.pack . show) $ httpGetRemoteRepo' uOrigin
+                            return (vcs, (raid, uClone, Just (Nothing, branch)))
+                )
+            )
+            pure
+            originTipOrBundle'
+
+    maybeNew <- withDBExcept $ do
+
+        -- Grab me from DB
+        (loomRecip, actorRecip) <- lift $ do
+            d <- getJust loomID
+            (d,) <$> getJust (loomActor d)
+
+        -- Grab loom's repo from DB and verify that it consents to be served by
+        -- the loom, otherwise this loom doesn't accept tickets
+        let recipLoomRepoID = loomRepo loomRecip
+        unless (targetRepoID == recipLoomRepoID) $
+            throwE "MR target repo isn't the one served by the Offer target loom"
+        targetRepo <- lift $ getJust targetRepoID
+        unless (repoLoom targetRepo == Just loomID) $
+            throwE "Offer target loom doesn't have repo's consent to serve it"
+
+        -- Verify VCS type match between patch bundle and target repo
+        let targetRepoVCS = repoVcs targetRepo
+        for_ (justThere originTipOrBundle) $ \ (Material typ diffs) -> do
+            unless (targetRepoVCS == patchMediaTypeVCS typ) $
+                throwE "Patch type and local target repo VCS mismatch"
+            case (typ, diffs) of
+                (PatchMediaTypeDarcs, _ :| _ : _) ->
+                    throwE "More than one Darcs dpatch file provided"
+                _ -> pure ()
+
+        -- If origin repo is local, find it in our DB.
+        --
+        -- Verify the (local or remote) origin repo's VCS type matches the
+        -- target repo.
+        originOrBundle' <-
+            bitraverse
+                (bitraverse
+                    (\ origin@(repoID, maybeBranch) -> do
+                        repo <- getE repoID "MR origin local repo not found in DB"
+                        unless (repoVcs repo == targetRepoVCS) $
+                            throwE "Local origin repo VCS differs from target repo VCS"
+                        return origin
+                    )
+                    (\ (vcs, origin) -> do
+                        unless (vcs == targetRepoVCS) $
+                            throwE "Remote origin repo VCS differs from target repo VCS"
+                        return origin
+                    )
+                )
+                pure
+                originTipOrBundle''
+
+        -- Verify that branches are specified for Git and aren't specified for
+        -- Darcs
+        -- Also, produce a data structure separating by VCS rather than by
+        -- local/remote origin, which we'll need for generating patches
+        tipInfo <- case targetRepoVCS of
+            VCSGit -> do
+                targetBranch <- fromMaybeE maybeTargetBranch "Local target repo is Git but no target branch specified"
+                maybeOrigin <- for (justHere originOrBundle') $ \case
+                    Left (originRepoID, maybeOriginBranch) -> do
+                        originBranch <- fromMaybeE maybeOriginBranch "Local origin repo is Git but no origin branch specified"
+                        return (Left originRepoID, originBranch)
+                    Right (_remoteActorID, uClone, maybeOriginBranch) -> do
+                        (_maybeURI, originBranch) <- fromMaybeE maybeOriginBranch "Remote origin repo is Git but no origin branch specified"
+                        return (Right uClone, originBranch)
+                return $ Left (targetBranch, maybeOrigin)
+            VCSDarcs -> do
+                verifyNothingE maybeTargetBranch "Local target repo is Darcs but target branch specified"
+                maybeOriginRepo <- for (justHere originOrBundle') $ \case
+                    Left (originRepoID, maybeOriginBranch) -> do
+                        verifyNothingE maybeOriginBranch "Local origin repo is Darcs but origin branch specified"
+                        return $ Left originRepoID
+                    Right (_remoteActorID, uClone, maybeOriginBranch) -> do
+                        verifyNothingE maybeOriginBranch "Remote origin repo is Darcs but origin branch specified"
+                        return $ Right uClone
+                return $ Right $ maybeOriginRepo
+
+        -- Insert the Offer to my inbox
+        mractid <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) False
+        for mractid $ \ offerDB -> do
+
+            -- If a capability is provided, check it
+            for_ maybeCapability $ \ cap -> do
+                lcap <-
+                    case cap of
+                        Left c -> pure c
+                        Right _ -> throwE "Capability is a remote URI, i.e. not authored by me"
+                verifyCapability'
+                    lcap
+                    authorIdMsig
+                    (GrantResourceLoom loomID)
+                    AP.RoleReport
+
+            -- Prepare forwarding the Offer to my followers
+            let recipByID = grantResourceLocalActor $ GrantResourceLoom loomID
+            recipByHash <- hashLocalActor recipByID
+            let sieve = makeRecipientSet [] [localActorFollowers recipByHash]
+
+            -- Insert the new ticket to our DB
+            acceptID <- lift $ insertEmptyOutboxItem' (actorOutbox actorRecip) now
+            offerDB' <-
+                bitraverse
+                (traverseOf _1 $ \case
+                    LocalActorPerson personID -> pure personID
+                    _ -> throwE "Local non-Person ticket authors not allowed"
+                )
+                pure
+                offerDB
+            ticketID <- lift $ insertTask title desc source offerDB' acceptID
+            clothID <- lift $ insertMerge loomID ticketID maybeTargetBranch originOrBundle'
+            let maybePull =
+                    let maybeTipInfo =
+                            case tipInfo of
+                                Left (b, mo) -> Left . (b,) <$> mo
+                                Right mo -> Right <$> mo
+                        hasBundle = isJust $ justThere originOrBundle'
+                    in  (clothID, targetRepoID, hasBundle,) <$> maybeTipInfo
+
+            -- Prepare an Accept activity and insert to my outbox
+            accept@(actionAccept, _, _, _) <- lift $ prepareAccept clothID
+            let recipByKey = LocalActorLoom loomID
+            _luAccept <- lift $ updateOutboxItem' recipByKey acceptID actionAccept
+
+            return (loomActor loomRecip, sieve, acceptID, accept, maybePull)
+
+    case maybeNew of
+        Nothing -> done "I already have this activity in my inbox"
+        Just (loomActorID, sieve, acceptID, (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept), maybePull) -> do
+            traverse_ generatePatches maybePull
+            forwardActivity
+                authorIdMsig body (LocalActorLoom loomID) loomActorID sieve
+            lift $ sendActivity
+                (LocalActorLoom loomID) loomActorID localRecipsAccept
+                remoteRecipsAccept fwdHostsAccept acceptID actionAccept
+            done "Opened a MR and forwarded the Offer"
+
+    where
+
+    insertTask title desc source offerDB acceptID = do
+        did <- insert Discussion
+        fsid <- insert FollowerSet
+        tid <- insert Ticket
+            { ticketNumber      = Nothing
+            , ticketCreated     = now
+            , ticketTitle       = title
+            , ticketSource      = source
+            , ticketDescription = desc
+            , ticketDiscuss     = did
+            , ticketFollowers   = fsid
+            , ticketAccept      = acceptID
+            }
+        case offerDB of
+            Left (personID, _, offerID) ->
+                insert_ TicketAuthorLocal
+                    { ticketAuthorLocalTicket = tid
+                    , ticketAuthorLocalAuthor = personID
+                    , ticketAuthorLocalOpen   = offerID
+                    }
+            Right (author, _, offerID) ->
+                insert_ TicketAuthorRemote
+                    { ticketAuthorRemoteTicket = tid
+                    , ticketAuthorRemoteAuthor = remoteAuthorId author
+                    , ticketAuthorRemoteOpen   = offerID
+                    }
+        return tid
+
+    insertMerge
+        :: LoomId
+        -> TicketId
+        -> Maybe Text
+        -> These
+            (Either
+                (RepoId, Maybe Text)
+                (RemoteActorId, FedURI, Maybe (Maybe LocalURI, Text))
+            )
+            Material
+        -> ActDB TicketLoomId
+    insertMerge loomID ticketID maybeTargetBranch originOrBundle = do
+        clothID <- insert $ TicketLoom ticketID loomID maybeTargetBranch
+        for_ (justHere originOrBundle) $ \case
+            Left (repoID, maybeOriginBranch) ->
+                insert_ $ MergeOriginLocal clothID repoID maybeOriginBranch
+            Right (remoteActorID, _uClone, maybeOriginBranch) -> do
+                originID <- insert $ MergeOriginRemote clothID remoteActorID
+                for_ maybeOriginBranch $ \ (mlu, b) ->
+                    insert_ $ MergeOriginRemoteBranch originID mlu b
+        for_ (justThere originOrBundle) $ \ (Material typ diffs) -> do
+            bundleID <- insert $ Bundle clothID False
+            insertMany_ $ NE.toList $ NE.reverse $
+                NE.map (Patch bundleID now typ) diffs
+        return clothID
+
+    prepareAccept clothID = do
+        encodeRouteHome <- getEncodeRouteHome
+        encodeRouteLocal <- getEncodeRouteLocal
+
+        audSender <- makeAudSenderWithFollowers authorIdMsig
+        loomHash <- encodeKeyHashid loomID
+        clothHash <- encodeKeyHashid clothID
+        let audLoom = AudLocal [] [LocalStageLoomFollowers loomHash]
+        uOffer <- lift $ getActivityURI authorIdMsig
+
+        let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
+                collectAudience [audSender, audLoom]
+
+            recips = map encodeRouteHome audLocal ++ audRemote
+            action = AP.Action
+                { AP.actionCapability = Nothing
+                , AP.actionSummary    = Nothing
+                , AP.actionAudience   = AP.Audience recips [] [] [] [] []
+                , AP.actionFulfills   = [uOffer]
+                , AP.actionSpecific   = AP.AcceptActivity AP.Accept
+                    { AP.acceptObject   = uOffer
+                    , AP.acceptResult   =
+                        Just $ encodeRouteLocal $ ClothR loomHash clothHash
+                    }
+                }
+
+        return (action, recipientSet, remoteActors, fwdHosts)
 
 loomBehavior :: UTCTime -> LoomId -> VerseExt -> ActE (Text, Act (), Next)
-loomBehavior now loomID (Left _verse@(Verse _authorIdMsig body)) =
+loomBehavior now loomID (Left verse@(Verse _authorIdMsig body)) =
     case AP.activitySpecific $ actbActivity body of
+        AP.OfferActivity offer   -> loomOffer now loomID verse offer
         _ -> throwE "Unsupported activity type for Loom"
 loomBehavior _ _ (Right _) = throwE "ClientMsgs aren't supported for Loom"
 

src/Vervis/Federation/Ticket.hs

@@ -18,11 +18,10 @@
 
 module Vervis.Federation.Ticket
     ( --personOfferTicketF
-      loomOfferTicketF
 
     --, repoAddBundleF
 
-    , loomApplyF
+      loomApplyF
 
     --, deckOfferDepF
     --, repoOfferDepF
@@ -328,336 +327,6 @@ activityAlreadyInInbox hAct luAct inboxID = fmap isJust . runMaybeT $ do
     remoteActivityID <- MaybeT $ getKeyBy $ UniqueRemoteActivity remoteObjectID
     MaybeT $ getBy $ UniqueInboxItemRemote inboxID remoteActivityID
 
-loomOfferTicketF
-    :: UTCTime
-    -> KeyHashid Loom
-    -> RemoteAuthor
-    -> ActivityBody
-    -> Maybe (RecipientRoutes, ByteString)
-    -> LocalURI
-    -> AP.Ticket URIMode
-    -> FedURI
-    -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
-loomOfferTicketF now recipLoomHash author body mfwd luOffer ticket uTarget = do
-    error "loomOfferTicketF disabled for refactoring"
-{-
-    -- Check input
-    recipLoomID <- decodeKeyHashid404 recipLoomHash
-    (title, desc, source, originTipOrBundle, targetRepoID, maybeTargetBranch) <- do
-        let uAuthor@(ObjURI hAuthor _) = remoteAuthorURI author
-        WorkItemOffer {..} <- checkOfferTicket hAuthor ticket uTarget
-        unless (wioAuthor == Right (remoteAuthorURI author)) $
-            throwE "Offering a Ticket attributed to someone else"
-        Merge maybeOriginTip maybeBundle targetTip <- case wioRest of
-            TAM_Task _ ->
-                throwE
-                    "Offer target is some local deck, so I have no use for \
-                    \this Offer. Was I supposed to receive it?"
-            TAM_Merge loomID merge ->
-                if loomID == recipLoomID
-                    then return merge
-                    else throwE
-                            "Offer target is some other local loom, so I have \
-                            \no use for this Offer. Was I supposed to receive \
-                            \it?"
-            TAM_Remote _ _ ->
-                throwE
-                    "Offer target is some remote tracker, so I have no use \
-                    \for this Offer. Was I supposed to receive it?"
-        originTipOrBundle <-
-            fromMaybeE
-                (align maybeOriginTip maybeBundle)
-                "MR provides neither origin nor patches"
-        (targetRepoID, maybeTargetBranch) <-
-            case targetTip of
-                TipLocalRepo repoID -> pure (repoID, Nothing)
-                TipLocalBranch repoID branch -> pure (repoID, Just branch)
-                _ -> throwE "MR target is a remote repo (this tracker serves only local repos)"
-        return (wioTitle, wioDesc, wioSource, originTipOrBundle, targetRepoID, maybeTargetBranch)
-
-    -- Soon we're going to proceed asynchronously to be able to HTTP GET the
-    -- origin repo AP object, because:
-    --
-    --      * No support for providing a signed repo object directly in the
-    --        Offer activity
-    --      * It may be nice to make sure a remote origin repo's VCS type
-    --        matches the target repo's VCS, even if patches are provided too
-    --          + However there's no support for caching VCS type when
-    --            remembering remote repo in our DB, so we'd have to check this
-    --            every time
-    --      * If origin is remote and no patches are provided, we'll need to
-    --        know the clone URL to generate the patches ourselves
-    --          + However the code here, for some simplicity, doesn't have a
-    --            way to skip that and do the whole handler synchronously in
-    --            case patches are provided or the origin is a local repo
-    --          + And no support for caching the clone URI in DB when
-    --            remembering the remote repo, so we'd need to do this every
-    --            time
-    --
-    -- So first let's do some checks using the DB, on the loom, on the target
-    -- repo (which is always local), and on the origin repo if it's local
-    (recipLoomRepoID, Entity recipLoomActorID recipLoomActor, alreadyInInbox) <- lift $ runDB $ do
-
-        -- Find recipient loom in DB, returning 404 if doesn't exist because
-        -- we're in the loom's inbox post handler
-        (recipLoomRepoID, recipLoomActor@(Entity _ actor)) <- do
-            loom <- get404 recipLoomID
-            let actorID = loomActor loom
-            (loomRepo loom,) . Entity actorID <$> getJust actorID
-
-        -- Has the loom already received this activity to its inbox? If yes, we
-        -- won't process it again
-        alreadyInInbox <- do
-            let hOffer = objUriAuthority $ remoteAuthorURI author
-            activityAlreadyInInbox hOffer luOffer (actorInbox actor)
-
-        return (recipLoomRepoID, recipLoomActor, alreadyInInbox)
-
-    if alreadyInInbox
-        then return ("I already have this activity in my inbox, ignoring", Nothing)
-        else do
-            (targetRepoVCS, originOrBundle) <- runDBExcept $ do
-
-                -- Grab loom's repo from DB and verify that it consents to be served by
-                -- the loom, otherwise this loom doesn't accept tickets
-                unless (targetRepoID == recipLoomRepoID) $
-                    throwE "MR target repo isn't the one served by the Offer target loom"
-                targetRepo <- lift $ getJust targetRepoID
-                unless (repoLoom targetRepo == Just recipLoomID) $
-                    throwE "Offer target loom doesn't have repo's consent to serve it"
-
-                -- Verify VCS type match between patch bundle and target repo
-                for_ (justThere originTipOrBundle) $ \ (Material typ diffs) -> do
-                    unless (repoVcs targetRepo == patchMediaTypeVCS typ) $
-                        throwE "Patch type and local target repo VCS mismatch"
-                    case (typ, diffs) of
-                        (PatchMediaTypeDarcs, _ :| _ : _) ->
-                            throwE "More than one Darcs dpatch file provided"
-                        _ -> pure ()
-
-                -- If origin repo is local, find it in our DB and verify its VCS type
-                -- matches the target repo
-                originOrBundle <- flip (bifor originTipOrBundle) pure $ \ originTip -> do
-                    let origin =
-                            case originTip of
-                                TipLocalRepo repoID -> Left (repoID, Nothing)
-                                TipLocalBranch repoID branch -> Left (repoID, Just branch)
-                                TipRemote uOrigin -> Right (uOrigin, Nothing)
-                                TipRemoteBranch uRepo branch -> Right (uRepo, Just branch)
-                    bitraverse_
-                        (\ (repoID, maybeBranch) -> do
-                            repo <- getE repoID "MR origin local repo not found in DB"
-                            unless (repoVcs repo == repoVcs targetRepo) $
-                                throwE "Local origin repo VCS differs from target repo VCS"
-                        )
-                        pure
-                        origin
-                    return origin
-
-                return (repoVcs targetRepo, originOrBundle)
-
-            return $ (,) "Ran initial checks, doing the rest asynchronously" $ Just $ do
-
-                -- If origin repo is remote, HTTP GET its AP representation and
-                -- remember it in our DB
-                originOrBundle' <-
-                    bitraverse
-                        (bitraverse
-                            pure
-                            (\ (uOrigin, maybeOriginBranch) -> do
-                                (vcs, remoteOrigin) <-
-                                    case maybeOriginBranch of
-                                        Nothing -> do
-                                            (vcs, raid, uClone, mb) <- withExceptT (T.pack . show) $ httpGetRemoteTip uOrigin
-                                            return (vcs, (raid, uClone, first Just <$> mb))
-                                        Just branch -> do
-                                            (vcs, raid, uClone) <- withExceptT (T.pack . show) $ httpGetRemoteRepo uOrigin
-                                            return (vcs, (raid, uClone, Just (Nothing, branch)))
-                                unless (vcs == targetRepoVCS) $
-                                    throwE "Remote origin repo VCS differs from target repo VCS"
-                                return remoteOrigin
-                            )
-                        )
-                        pure
-                        originOrBundle
-
-                -- Verify that branches are specified for Git and aren't specified for
-                -- Darcs
-                -- Also, produce a data structure separating by VCS rather than by
-                -- local/remote origin, which we'll need for generating patches
-                tipInfo <- case targetRepoVCS of
-                    VCSGit -> do
-                        targetBranch <- fromMaybeE maybeTargetBranch "Local target repo is Git but no target branch specified"
-                        maybeOrigin <- for (justHere originOrBundle') $ \case
-                            Left (originRepoID, maybeOriginBranch) -> do
-                                originBranch <- fromMaybeE maybeOriginBranch "Local origin repo is Git but no origin branch specified"
-                                return (Left originRepoID, originBranch)
-                            Right (_remoteActorID, uClone, maybeOriginBranch) -> do
-                                (_maybeURI, originBranch) <- fromMaybeE maybeOriginBranch "Remote origin repo is Git but no origin branch specified"
-                                return (Right uClone, originBranch)
-                        return $ Left (targetBranch, maybeOrigin)
-                    VCSDarcs -> do
-                        verifyNothingE maybeTargetBranch "Local target repo is Darcs but target branch specified"
-                        maybeOriginRepo <- for (justHere originOrBundle') $ \case
-                            Left (originRepoID, maybeOriginBranch) -> do
-                                verifyNothingE maybeOriginBranch "Local origin repo is Darcs but origin branch specified"
-                                return $ Left originRepoID
-                            Right (_remoteActorID, uClone, maybeOriginBranch) -> do
-                                verifyNothingE maybeOriginBranch "Remote origin repo is Darcs but origin branch specified"
-                                return $ Right uClone
-                        return $ Right $ maybeOriginRepo
-
-                maybeHttp <- runSiteDBExcept $ do
-
-                    -- Insert the Offer to loom's inbox
-                    mractid <- lift $ insertToInbox now author body (actorInbox recipLoomActor) luOffer False
-                    for mractid $ \ offerID -> do
-
-                        -- Forward the Offer activity to relevant local stages, and
-                        -- schedule delivery for unavailable remote members of them
-                        maybeHttpFwdOffer <- lift $ for mfwd $ \ (localRecips, sig) -> do
-                            let sieve =
-                                    makeRecipientSet
-                                        []
-                                        [LocalStageLoomFollowers recipLoomHash]
-                            forwardActivityDB
-                                (actbBL body) localRecips sig
-                                recipLoomActorID (LocalActorLoom recipLoomHash)
-                                sieve offerID
-
-                        -- Insert the new ticket to our DB
-                        acceptID <- lift $ insertEmptyOutboxItem (actorOutbox recipLoomActor) now
-                        ticketID <- lift $ insertTicket now title desc source offerID acceptID
-                        clothID <- lift $ insertMerge recipLoomID ticketID maybeTargetBranch originOrBundle'
-                        let maybePull =
-                                let maybeTipInfo =
-                                        case tipInfo of
-                                            Left (b, mo) -> Left . (b,) <$> mo
-                                            Right mo -> Right <$> mo
-                                    hasBundle = isJust $ justThere originOrBundle'
-                                in  (clothID, targetRepoID, hasBundle,) <$> maybeTipInfo
-
-                        -- Prepare an Accept activity and insert to loom's outbox
-                        (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
-                            lift $ prepareAccept clothID
-                        _luAccept <- lift $ updateOutboxItem (LocalActorLoom recipLoomID) acceptID actionAccept
-
-                        -- Deliver the Accept to local recipients, and schedule delivery
-                        -- for unavailable remote recipients
-                        deliverHttpAccept <-
-                            deliverActivityDB
-                                (LocalActorLoom recipLoomHash) recipLoomActorID
-                                localRecipsAccept remoteRecipsAccept
-                                fwdHostsAccept acceptID actionAccept
-
-                        -- Return instructions for HTTP inbox-forwarding of the Offer
-                        -- activity, and for HTTP delivery of the Accept activity to
-                        -- remote recipients, and for generating patches from
-                        -- the origin repo
-                        return
-                            (maybeHttpFwdOffer, deliverHttpAccept, maybePull)
-
-                -- Launch asynchronous HTTP forwarding of the Offer activity and HTTP
-                -- delivery of the Accept activity, and generate patches if we opened
-                -- a local MR that mentions just an origin
-                case maybeHttp of
-                    Nothing ->
-                        return
-                            "When I started serving this activity, I didn't have it in my inbox, \
-                            \but now suddenly it seems I already do, so ignoring"
-                    Just (maybeHttpFwdOffer, deliverHttpAccept, maybePull) -> do
-                        forkWorker "loomOfferTicketF Accept HTTP delivery" deliverHttpAccept
-                        traverse generatePatches maybePull
-                        case maybeHttpFwdOffer of
-                            Nothing -> return "Opened a merge request, no inbox-forwarding to do"
-                            Just forwardHttpOffer -> do
-                                forkWorker "loomOfferTicketF inbox-forwarding" forwardHttpOffer
-                                return "Opened a merge request and ran inbox-forwarding of the Offer"
-
-    where
-
-    insertTicket now title desc source offerID acceptID = do
-        did <- insert Discussion
-        fsid <- insert FollowerSet
-        tid <- insert Ticket
-            { ticketNumber      = Nothing
-            , ticketCreated     = now
-            , ticketTitle       = title
-            , ticketSource      = source
-            , ticketDescription = desc
-            , ticketDiscuss     = did
-            , ticketFollowers   = fsid
-            , ticketAccept      = acceptID
-            }
-        insert_ TicketAuthorRemote
-            { ticketAuthorRemoteTicket = tid
-            , ticketAuthorRemoteAuthor = remoteAuthorId author
-            , ticketAuthorRemoteOpen   = offerID
-            }
-        return tid
-
-    insertMerge
-        :: LoomId
-        -> TicketId
-        -> Maybe Text
-        -> These
-            (Either
-                (RepoId, Maybe Text)
-                (RemoteActorId, FedURI, Maybe (Maybe LocalURI, Text))
-            )
-            Material
-        -> WorkerDB TicketLoomId
-    insertMerge loomID ticketID maybeTargetBranch originOrBundle = do
-        clothID <- insert $ TicketLoom ticketID loomID maybeTargetBranch
-        for_ (justHere originOrBundle) $ \case
-            Left (repoID, maybeOriginBranch) ->
-                insert_ $ MergeOriginLocal clothID repoID maybeOriginBranch
-            Right (remoteActorID, _uClone, maybeOriginBranch) -> do
-                originID <- insert $ MergeOriginRemote clothID remoteActorID
-                for_ maybeOriginBranch $ \ (mlu, b) ->
-                    insert_ $ MergeOriginRemoteBranch originID mlu b
-        for_ (justThere originOrBundle) $ \ (Material typ diffs) -> do
-            bundleID <- insert $ Bundle clothID False
-            insertMany_ $ NE.toList $ NE.reverse $
-                NE.map (Patch bundleID now typ) diffs
-        return clothID
-
-    prepareAccept clothID = do
-        encodeRouteLocal <- getEncodeRouteLocal
-        encodeRouteHome <- getEncodeRouteHome
-
-        clothHash <- encodeKeyHashid clothID
-
-        ra <- getJust $ remoteAuthorId author
-
-        let ObjURI hAuthor luAuthor = remoteAuthorURI author
-
-            audSender =
-                AudRemote hAuthor
-                    [luAuthor]
-                    (maybeToList $ remoteActorFollowers ra)
-            audTracker = AudLocal [] [LocalStageLoomFollowers recipLoomHash]
-
-            (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
-                collectAudience [audSender, audTracker]
-
-            recips = map encodeRouteHome audLocal ++ audRemote
-            action = AP.Action
-                { AP.actionCapability = Nothing
-                , AP.actionSummary    = Nothing
-                , AP.actionAudience   = AP.Audience recips [] [] [] [] []
-                , AP.actionFulfills   = []
-                , AP.actionSpecific   = AP.AcceptActivity AP.Accept
-                    { AP.acceptObject   = ObjURI hAuthor luOffer
-                    , AP.acceptResult   =
-                        Just $ encodeRouteLocal $
-                            ClothR recipLoomHash clothHash
-                    }
-                }
-
-        return (action, recipientSet, remoteActors, fwdHosts)
--}
-
 repoOfferTicketF
     :: UTCTime
     -> KeyHashid Repo

src/Vervis/Fetch.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2022 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -16,7 +16,9 @@
 module Vervis.Fetch
     ( Result (..)
     , httpGetRemoteTip
+    , httpGetRemoteTip'
     , httpGetRemoteRepo
+    , httpGetRemoteRepo'
     )
 where
 
@@ -60,6 +62,7 @@ import qualified Data.Text as T
 import qualified Data.Text.Encoding as TE
 import qualified Data.Text.Lazy as TL
 
+import Control.Concurrent.Actor
 import Database.Persist.JSON
 import Development.PatchMediaType
 import Network.FedURI
@@ -81,6 +84,7 @@ import qualified Data.Text.UTF8.Local as TU
 import qualified Darcs.Local.Repository as D (createRepo)
 
 --import Vervis.Access
+import Vervis.Actor
 import Vervis.ActivityPub
 import Vervis.Cloth
 import Vervis.Data.Actor
@@ -116,6 +120,13 @@ fetchRepoE h lu = do
     ExceptT $ first (maybe ResultIdMismatch ResultGetError) <$>
         fetchAPID' manager apRepoId h lu
 
+fetchRepoE' :: Host -> LocalURI -> ExceptT Result Act (AP.Repo URIMode)
+fetchRepoE' h lu = do
+    manager <- asksEnv envHttpManager
+    let apRepoId = AP.actorId . AP.actorLocal . AP.repoActor
+    ExceptT $ first (maybe ResultIdMismatch ResultGetError) <$>
+        fetchAPID' manager apRepoId h lu
+
 insertRemoteActor
     :: MonadIO m
     => Host
@@ -167,6 +178,36 @@ httpGetRemoteTip (ObjURI host localURI) = do
         ExceptT $ first (maybe ResultIdMismatch ResultGetError) <$>
             fetchTip manager h lu
 
+httpGetRemoteTip'
+    :: FedURI
+    -> ExceptT Result Act
+        ( VersionControlSystem
+        , RemoteActorId
+        , FedURI
+        , Maybe (LocalURI, Text)
+        )
+httpGetRemoteTip' (ObjURI host localURI) = do
+    repoOrBranch <- fetchTipE host localURI
+    case repoOrBranch of
+        Left repo -> do
+            remoteActorID <-
+                lift $ withDB $
+                    insertRemoteActor host localURI $ AP.repoActor repo
+            let uClone = ObjURI host $ NE.head $ AP.repoClone repo
+            return (AP.repoVcs repo, remoteActorID, uClone, Nothing)
+        Right (AP.Branch name _ luRepo) -> do
+            repo <- fetchRepoE' host luRepo
+            remoteActorID <-
+                lift $ withDB $
+                    insertRemoteActor host luRepo $ AP.repoActor repo
+            let uClone = ObjURI host $ NE.head $ AP.repoClone repo
+            return (AP.repoVcs repo, remoteActorID, uClone, Just (localURI, name))
+    where
+    fetchTipE h lu = do
+        manager <- asksEnv envHttpManager
+        ExceptT $ first (maybe ResultIdMismatch ResultGetError) <$>
+            fetchTip manager h lu
+
 httpGetRemoteRepo
     :: (MonadUnliftIO m, MonadSite m, SiteEnv m ~ App)
     => FedURI
@@ -178,3 +219,14 @@ httpGetRemoteRepo (ObjURI host localURI) = do
             insertRemoteActor host localURI $ AP.repoActor repo
     let uClone = ObjURI host $ NE.head $ AP.repoClone repo
     return (AP.repoVcs repo, remoteActorID, uClone)
+
+httpGetRemoteRepo'
+    :: FedURI
+    -> ExceptT Result Act (VersionControlSystem, RemoteActorId, FedURI)
+httpGetRemoteRepo' (ObjURI host localURI) = do
+    repo <- fetchRepoE' host localURI
+    remoteActorID <-
+        lift $ withDB $
+            insertRemoteActor host localURI $ AP.repoActor repo
+    let uClone = ObjURI host $ NE.head $ AP.repoClone repo
+    return (AP.repoVcs repo, remoteActorID, uClone)

src/Vervis/Handler/Person.hs

@@ -222,7 +222,6 @@ postPersonOutboxR personHash = do
                 -> t
             run f = f eperson actorDB maybeCap localRecips remoteRecips fwdHosts action
         case specific of
-            AP.AcceptActivity accept -> run acceptC accept
             AP.ApplyActivity apply -> run applyC apply
             AP.CreateActivity (AP.Create obj mtarget) ->
                 case obj of
@@ -246,7 +245,10 @@ postPersonOutboxR personHash = do
             AP.FollowActivity follow -> run followC follow
             AP.OfferActivity (AP.Offer obj target) ->
                 case obj of
-                    AP.OfferTicket ticket -> run offerTicketC ticket target
+                    AP.OfferTicket _ ->
+                        handleViaActor
+                            (entityKey eperson) maybeCap localRecips remoteRecips
+                            fwdHosts action
                     {-
                     OfferDep dep ->
                         offerDepC eperson sharer summary audience dep target

src/Vervis/Path.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2016, 2019, 2022 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2016, 2019, 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -17,6 +17,7 @@ module Vervis.Path
     ( askRepoRootDir
     , repoDir
     , askRepoDir
+    , askRepoDir'
     )
 where
 
@@ -26,9 +27,11 @@ import System.FilePath ((</>))
 import qualified Data.CaseInsensitive as CI (foldedCase)
 import qualified Data.Text as T (unpack)
 
+import Control.Concurrent.Actor
 import Yesod.Hashids
 import Yesod.MonadSite
 
+import Vervis.Actor
 import Vervis.Foundation
 import Vervis.Model
 import Vervis.Settings
@@ -36,6 +39,9 @@ import Vervis.Settings
 askRepoRootDir :: (MonadSite m, SiteEnv m ~ App) => m FilePath
 askRepoRootDir = asksSite $ appRepoDir . appSettings
 
+askRepoRootDir' :: Act FilePath
+askRepoRootDir' = asksEnv $ appRepoDir . envSettings
+
 repoDir :: FilePath -> KeyHashid Repo -> FilePath
 repoDir root repo = root </> (T.unpack $ keyHashidText repo)
 
@@ -44,3 +50,8 @@ askRepoDir
 askRepoDir repo = do
     root <- askRepoRootDir
     return $ repoDir root repo
+
+askRepoDir' :: KeyHashid Repo -> Act FilePath
+askRepoDir' repo = do
+    root <- askRepoRootDir'
+    return $ repoDir root repo

src/Vervis/Web/Repo.hs

@@ -1,6 +1,7 @@
 {- This file is part of Vervis.
  -
- - Written in 2019, 2020, 2021, 2022 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2019, 2020, 2021, 2022, 2023
+ - by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -45,11 +46,13 @@ import Yesod.Hashids
 import Yesod.MonadSite
 
 import qualified Web.ActivityPub as AP
+import qualified Web.Actor.Persist as WAP
 
 import Data.Patch.Local hiding (Patch)
 
 import qualified Data.Patch.Local as P
 
+import Vervis.Actor
 import Vervis.Darcs
 import Vervis.FedURI
 import Vervis.Foundation
@@ -110,36 +113,35 @@ serveCommit repoHash ref patch parents = do
         Right $ encodeRouteHome $ PersonR $ hashPerson personID
 
 generatePatches
-    :: (MonadUnliftIO m, MonadSite m, SiteEnv m ~ App)
+    :: ( TicketLoomId
-    => ( TicketLoomId
        , RepoId
        , Bool
        , Either
             (Text, (Either RepoId FedURI, Text))
             (Either RepoId FedURI)
        )
-    -> ExceptT Text m ()
+    -> ActE ()
 generatePatches (clothID, targetRepoID, hasBundle, tipInfo) = unless hasBundle $ do
     patches <-
         case tipInfo of
             Right _ -> error "Auto-pulling from Darcs remote origin not supported yet"
             Left (targetBranch, (originRepo, originBranch)) -> do
                 targetPath <- do
-                    repoHash <- encodeKeyHashid targetRepoID
+                    repoHash <- WAP.encodeKeyHashid targetRepoID
-                    repoDir <- askRepoDir repoHash
+                    repoDir <- lift $ askRepoDir' repoHash
                     liftIO $ makeAbsolute repoDir
                 originURI <-
                     case originRepo of
                         Left repoID -> do
-                            repoHash <- encodeKeyHashid repoID
+                            repoHash <- WAP.encodeKeyHashid repoID
-                            repoDir <- askRepoDir repoHash
+                            repoDir <- lift $ askRepoDir' repoHash
                             liftIO $ makeAbsolute repoDir
                         Right uClone -> pure $ T.unpack $ renderObjURI uClone
                 ExceptT $ liftIO $ runExceptT $
                     withSystemTempDirectory "vervis-generatePatches" $
                         generateGitPatches targetPath (T.unpack targetBranch) originURI (T.unpack originBranch)
     now <- liftIO getCurrentTime
-    lift $ runSiteDB $ do
+    lift $ withDB $ do
         bundleID <- insert $ Bundle clothID True
         insertMany_ $ NE.toList $ NE.map (Patch bundleID now PatchMediaTypeGit) $ NE.reverse patches