UI: Use the actor system for opening a ticket, and remove offerTicketC

src/Vervis/API.hs

@@ -26,7 +26,6 @@ module Vervis.API
     , createPatchTrackerC
     , createRepositoryC
     , followC
-    , offerTicketC
     --, offerDepC
     , resolveC
     , undoC
@@ -1652,352 +1651,6 @@ followC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips re
                 }
             }
 
-offerTicketC
-    :: Entity Person
-    -> Actor
-    -> Maybe
-        (Either
-            (LocalActorBy Key, LocalActorBy KeyHashid, OutboxItemId)
-            FedURI
-        )
-    -> RecipientRoutes
-    -> [(Host, NonEmpty LocalURI)]
-    -> [Host]
-    -> AP.Action URIMode
-    -> AP.Ticket URIMode
-    -> FedURI
-    -> ExceptT Text Handler OutboxItemId
-offerTicketC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips remoteRecips fwdHosts action ticket uTarget = do
-
-    -- Check input
-    verifyNothingE maybeCap "Capability not needed"
-    (title, desc, source, tam) <- do
-        hostLocal <- asksSite siteInstanceHost
-        WorkItemOffer {..} <- VA2.runActE $ checkOfferTicket hostLocal ticket uTarget
-        unless (wioAuthor == Left senderPersonID) $
-            throwE "Offering a Ticket attributed to someone else"
-        return (wioTitle, wioDesc, wioSource, wioRest)
-
-    -- Verify that the target tracker is addressed by the Offer
-    case tam of
-        TAM_Task deckID -> do
-            deckHash <- encodeKeyHashid deckID
-            unless (actorIsAddressed localRecips $ LocalActorDeck deckHash) $
-                throwE "Local target deck not addressed by the Offer"
-        TAM_Merge loomID _ -> do
-            loomHash <- encodeKeyHashid loomID
-            unless (actorIsAddressed localRecips $ LocalActorLoom loomHash) $
-                throwE "Local target loom not addressed by the Offer"
-        TAM_Remote uTracker _ -> verifyRemoteAddressed remoteRecips uTracker
-
-    senderHash <- encodeKeyHashid senderPersonID
-    now <- liftIO getCurrentTime
-
-    -- If tracker is a local loom, and a remote origin repo is specified, fetch
-    -- that repo's AP object via HTTP and remember in DB
-    maybeLocalTracker <-
-        case tam of
-            TAM_Task deckID -> pure $ Just $ Left deckID
-            TAM_Merge loomID (Merge maybeOriginTip maybeBundle targetTip) -> do
-                maybeOrigin <- for maybeOriginTip $ \case
-                    TipLocalRepo repoID -> pure $ Left (repoID, Nothing)
-                    TipLocalBranch repoID branch -> pure $ Left (repoID, Just branch)
-                    TipRemote uOrigin -> Right <$> do
-                        (vcs, raid, uClone, mb) <- withExceptT (T.pack . show) $ httpGetRemoteTip uOrigin
-                        return (vcs, raid, uClone, first Just <$> mb)
-                    TipRemoteBranch uRepo branch -> Right <$> do
-                        (vcs, raid, uClone) <- withExceptT (T.pack . show) $ httpGetRemoteRepo uRepo
-                        return (vcs, raid, uClone, Just (Nothing, branch))
-                originOrBundle <-
-                    fromMaybeE
-                        (align maybeOrigin 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 "Offer target is a local loom but MR target is a remote repo (Looms serve only local repos)"
-                return $ Just $ Right (loomID, originOrBundle, targetRepoID, maybeTargetBranch)
-            TAM_Remote _ _ -> pure Nothing
-
-    (offerID, deliverHttpOffer, maybeAcceptMaybePull) <- runDBExcept $ do
-
-        -- If target tracker is local, find it in our DB
-        -- If that tracker is a loom, find and check the MR too
-        maybeLocalTrackerDB <- for maybeLocalTracker $ bitraverse
-            (\ deckID -> do
-                deck <- getE deckID "Offer local target no such deck in DB"
-                return (deckID, deckActor deck)
-            )
-            (\ (loomID, originOrBundle, targetRepoID, maybeTargetBranch) -> do
-                loom <- getE loomID "Offer local target no such loom in DB"
-
-                unless (targetRepoID == loomRepo loom) $
-                    throwE "MR target repo isn't the one served by the Offer target loom"
-                targetRepo <- getE targetRepoID "MR target local repo not found in DB"
-                unless (repoLoom targetRepo == Just loomID) $
-                    throwE "Offer target loom doesn't have repo's consent to serve it"
-
-                for_ (justThere originOrBundle) $ \ (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 ()
-
-                originOrBundle' <-
-                    bitraverse
-                        (\ origin -> do
-                            (vcs, origin') <-
-                                case origin of
-                                    Left (repoID, maybeBranch) -> do
-                                        repo <- getE repoID "MR origin local repo not found in DB"
-                                        return (repoVcs repo, Left (repoID, maybeBranch))
-                                    Right (vcs, remoteActorID, uClone, maybeBranch) ->
-                                        pure (vcs, Right (remoteActorID, uClone, maybeBranch))
-                            unless (vcs == repoVcs targetRepo) $
-                                throwE "Origin repo VCS differs from target repo VCS"
-                            return origin'
-                        )
-                        pure
-                        originOrBundle
-
-                -- Verify that the VCS of target repo, origin repo and patches
-                -- all match, and that branches are specified for Git and
-                -- aren't specified for Darcs
-                tipInfo <- case repoVcs targetRepo 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
-
-                return (loomID, loomActor loom, originOrBundle', targetRepoID, maybeTargetBranch, tipInfo)
-            )
-
-        -- Insert Offer to sender's outbox
-        offerID <- lift $ insertEmptyOutboxItem (actorOutbox senderActor) now
-        luOffer <- lift $ updateOutboxItem (LocalActorPerson senderPersonID) offerID action
-
-        -- Deliver the Offer activity to local recipients, and schedule
-        -- delivery for unavailable remote recipients
-        deliverHttpOffer <- do
-            hashRepo <- getEncodeKeyHashid
-            let tipRepo tip =
-                    case tip of
-                        TipLocalRepo repoID -> Just $ hashRepo repoID
-                        TipLocalBranch repoID _ -> Just $ hashRepo repoID
-                        _ -> Nothing
-            hashDeck <- getEncodeKeyHashid
-            hashLoom <- getEncodeKeyHashid
-            let (tracker, target, origin) =
-                    case tam of
-                        TAM_Task deckID ->
-                            ( Just $ Left $ hashDeck deckID
-                            , Nothing
-                            , Nothing
-                            )
-                        TAM_Merge loomID (Merge maybeOriginTip _ targetTip) ->
-                            ( Just $ Right $ hashLoom loomID
-                            , tipRepo targetTip
-                            , tipRepo =<< maybeOriginTip
-                            )
-                        TAM_Remote _ maybeMerge ->
-                            ( Nothing
-                            , tipRepo . mergeTarget =<< maybeMerge
-                            , tipRepo =<< mergeOrigin =<< maybeMerge
-                            )
-                sieveActors = catMaybes
-                    [ tracker <&> \case
-                        Left deckHash -> LocalActorDeck deckHash
-                        Right loomHash -> LocalActorLoom loomHash
-                    , LocalActorRepo <$> target
-                    , LocalActorRepo <$> origin
-                    ]
-                sieveStages = catMaybes
-                    [ tracker <&> \case
-                        Left deckHash -> LocalStageDeckFollowers deckHash
-                        Right loomHash -> LocalStageLoomFollowers loomHash
-                    , LocalStageRepoFollowers <$> target
-                    , LocalStageRepoFollowers <$> origin
-                    , Just $ LocalStagePersonFollowers senderHash
-                    ]
-                sieve = makeRecipientSet sieveActors sieveStages
-                localRecipsFinal = localRecipSieve sieve False localRecips
-            deliverActivityDB
-                (LocalActorPerson senderHash) (personActor senderPerson)
-                localRecipsFinal remoteRecips fwdHosts offerID action
-
-        -- If Offer target is a local deck/loom, verify that it has received
-        -- the Offer, insert a new Ticket to DB, and publish Accept
-        maybeAcceptMaybePull <- for maybeLocalTrackerDB $ \ tracker -> do
-
-            -- Verify that tracker received the Offer
-            let trackerActorID =
-                    case tracker of
-                        Left (_, actorID) -> actorID
-                        Right (_, actorID, _, _, _, _) -> actorID
-            verifyActorHasItem trackerActorID offerID "Local tracker didn't receive the Offer"
-
-            -- Insert ticket/MR to DB
-            acceptID <- lift $ do
-                trackerActor <- getJust trackerActorID
-                insertEmptyOutboxItem (actorOutbox trackerActor) now
-            (ticketRoute, maybePull) <- lift $ do
-                ticketID <- insertTicket now title desc source offerID acceptID
-                case tracker of
-                    Left (deckID, _) ->
-                        (,Nothing) <$> insertTask deckID ticketID
-                    Right (loomID, _, originOrBundle, targetRepoID, maybeTargetBranch, tipInfo) -> do
-                        (clothID, route) <- insertMerge now loomID ticketID maybeTargetBranch originOrBundle
-                        let maybeTipInfo =
-                                case tipInfo of
-                                    Left (b, mo) -> Left . (b,) <$> mo
-                                    Right mo -> Right <$> mo
-                            hasBundle = isJust $ justThere originOrBundle
-                            pull = (clothID, targetRepoID, hasBundle,) <$> maybeTipInfo
-                        return (route, pull)
-
-            -- Insert an Accept activity to tracker's outbox
-            hashDeck <- getEncodeKeyHashid
-            hashLoom <- getEncodeKeyHashid
-            let acceptRecipActors = [LocalActorPerson senderHash]
-                acceptRecipStages =
-                    [ case tracker of
-                        Left (deckID, _) ->
-                            LocalStageDeckFollowers $ hashDeck deckID
-                        Right (loomID, _, _, _, _, _) ->
-                            LocalStageLoomFollowers $ hashLoom loomID
-                    , LocalStagePersonFollowers senderHash
-                    ]
-            actionAccept <- prepareAccept ticketRoute luOffer acceptRecipActors acceptRecipStages
-            let trackerByKey =
-                    case tracker of
-                        Left (deckID, _) -> LocalActorDeck deckID
-                        Right (loomID, _, _, _, _, _) -> LocalActorLoom loomID
-            _luAccept <- lift $ updateOutboxItem trackerByKey acceptID actionAccept
-
-            -- Deliver the Accept activity to local recipients, and schedule
-            -- delivery for unavailable remote recipients
-            deliverHttpAccept <- do
-                let trackerLocalActor =
-                        case tracker of
-                            Left (deckID, _) ->
-                                LocalActorDeck $ hashDeck deckID
-                            Right (loomID, _, _, _, _, _) ->
-                                LocalActorLoom $ hashLoom loomID
-                    localRecipsAccept =
-                        makeRecipientSet acceptRecipActors acceptRecipStages
-                deliverActivityDB
-                    trackerLocalActor trackerActorID localRecipsAccept [] []
-                    acceptID actionAccept
-
-            -- Return instructions for HTTP delivery to remote recipients, and
-            -- info for pulling origin branch to generate patches
-            return (deliverHttpAccept, maybePull)
-
-        -- Return instructions for HTTP delivery to remote recipients, and info
-        -- for pulling origin branch to generate patches
-        return (offerID, deliverHttpOffer, maybeAcceptMaybePull)
-
-    -- Launch asynchronous HTTP delivery of Offer and Accept, and generate
-    -- patches if we opened a local MR that mentions just an origin
-    lift $ forkWorker "offerTicketC: async HTTP Offer delivery" deliverHttpOffer
-    for_ maybeAcceptMaybePull $ \ (deliverHttpAccept, maybePull) -> do
-        lift $ forkWorker "offerTicketC: async HTTP Accept delivery" deliverHttpAccept
-        VA2.runActE $ traverse generatePatches maybePull
-
-    return offerID
-
-    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_ TicketAuthorLocal
-            { ticketAuthorLocalTicket = tid
-            , ticketAuthorLocalAuthor = senderPersonID
-            , ticketAuthorLocalOpen   = offerID
-            }
-        return tid
-
-    insertTask deckID ticketID = do
-        ticketDeckID <- insert $ TicketDeck ticketID deckID
-        TicketR <$> encodeKeyHashid deckID <*> encodeKeyHashid ticketDeckID
-
-    insertMerge
-        :: UTCTime
-        -> LoomId
-        -> TicketId
-        -> Maybe Text
-        -> These
-            (Either
-                (RepoId, Maybe Text)
-                (RemoteActorId, FedURI, Maybe (Maybe LocalURI, Text))
-            )
-            Material
-        -> AppDB (TicketLoomId, Route App)
-    insertMerge now loomID ticketID maybeBranch originOrBundle = do
-        clothID <- insert $ TicketLoom ticketID loomID maybeBranch
-        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
-        route <- ClothR <$> encodeKeyHashid loomID <*> encodeKeyHashid clothID
-        return (clothID, route)
-
-    prepareAccept ticketRoute luOffer actors stages = do
-        encodeRouteLocal <- getEncodeRouteLocal
-        encodeRouteHome <- getEncodeRouteHome
-        hLocal <- asksSite siteInstanceHost
-        let recips =
-                map encodeRouteHome $
-                        map renderLocalActor actors ++
-                        map renderLocalStage stages
-        return Action
-            { actionCapability = Nothing
-            , actionSummary    = Nothing
-            , actionAudience   = Audience recips [] [] [] [] []
-            , actionFulfills   = []
-            , actionSpecific   = AcceptActivity Accept
-                { acceptObject   = ObjURI hLocal luOffer
-                , acceptResult   = Just $ encodeRouteLocal ticketRoute
-                }
-            }
-
 {-
 verifyHosterRecip _           _    (Right _) = return ()
 verifyHosterRecip localRecips name (Left wi) =

src/Vervis/Handler/Client.hs

@@ -689,7 +689,7 @@ postPublishR = do
             <|> ResultCreateMR <$> result7
             <|> ResultOfferMR <$> result8
 
-    ep@(Entity _ p) <- requireVerifiedAuth
+    ep@(Entity pid p) <- requireVerifiedAuth
     s <- runDB $ getJust $ personIdent p
     let shrAuthor = sharerIdent s
 
@@ -1063,7 +1063,8 @@ postPublishOfferMergeR = do
                 omgOriginRepo (Just omgOriginBranch)
         (localRecips, remoteRecips, fwdHosts, action) <-
             makeServerInput Nothing summary audience $ AP.OfferActivity $ AP.Offer (AP.OfferTicket ticket) omgTracker
-        offerID <- offerTicketC ep a Nothing localRecips remoteRecips fwdHosts action ticket omgTracker
+        offerID <-
+            handleViaActor pid Nothing localRecips remoteRecips fwdHosts action
         if trackerLocal
             then nameExceptT "Offer published but" $ runDBExcept $ do
                 ticketID <- do

src/Vervis/Handler/Cloth.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2020, 2022 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2020, 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -684,9 +684,7 @@ postClothNewR loomHash = do
             lift $ C.makeServerInput Nothing maybeSummary audience $
                 AP.OfferActivity $ AP.Offer (AP.OfferTicket ticket) uLoom
         offerID <-
-            offerTicketC
+            handleViaActor pid Nothing localRecips remoteRecips fwdHosts action
-                person senderActor Nothing localRecips remoteRecips fwdHosts action
-                ticket uLoom
         runDBExcept $ do
             mtal <- lift $ getValBy $ UniqueTicketAuthorLocalOpen offerID
             tal <- fromMaybeE mtal "Offer processed bu no ticket created"

src/Vervis/Handler/Ticket.hs

@@ -460,17 +460,22 @@ postTicketNewR deckHash = do
             lift $ C.makeServerInput Nothing maybeSummary audience $
                 AP.OfferActivity $ AP.Offer (AP.OfferTicket ticket) uDeck
         offerID <-
-            offerTicketC
+            handleViaActor pid Nothing localRecips remoteRecips fwdHosts action
-                person actor Nothing localRecips remoteRecips fwdHosts action
+        {-
-                ticket uDeck
         runDBExcept $ do
             mtal <- lift $ getValBy $ UniqueTicketAuthorLocalOpen offerID
             tal <- fromMaybeE mtal "Offer processed bu no ticket created"
             return $ ticketAuthorLocalTicket tal
+        -}
+        return ()
     case errorOrTicket of
         Left e -> do
             setMessage $ toHtml e
             redirect $ TicketNewR deckHash
+        Right () -> do
+            setMessage "Offer activity sent"
+            redirect $ DeckTicketsR deckHash
+        {-
         Right ticketID -> do
             taskID <- do
                 maybeTaskID <- runDB $ getKeyBy $ UniqueTicketDeck ticketID
@@ -480,6 +485,7 @@ postTicketNewR deckHash = do
             taskHash <- encodeKeyHashid taskID
             setMessage "Ticket created"
             redirect $ TicketR deckHash taskHash
+        -}
 
 postTicketFollowR :: KeyHashid Deck -> KeyHashid TicketDeck -> Handler ()
 postTicketFollowR _ = error "Temporarily disabled"