S2S: deckOfferTicketF (i.e. local deck receives ticket from remote author)

src/Vervis/Federation/Ticket.hs

@@ -14,19 +14,20 @@
  -}
 
 module Vervis.Federation.Ticket
-    ( personOfferTicketF
+    ( --personOfferTicketF
-    , deckOfferTicketF
+      deckOfferTicketF
-    , repoOfferTicketF
+    --, repoOfferTicketF
 
-    , repoAddBundleF
+    --, repoAddBundleF
 
-    , repoApplyF
+    --, repoApplyF
+    --, loomApplyF
 
-    , deckOfferDepF
+    --, deckOfferDepF
-    , repoOfferDepF
+    --, repoOfferDepF
 
-    , deckResolveF
+    --, deckResolveF
-    , repoResolveF
+    --, repoResolveF
     )
 where
 
@@ -90,7 +91,9 @@ import Development.PatchMediaType
 
 import Vervis.ActivityPub
 import Vervis.Cloth
+import Vervis.Data.Ticket
 import Vervis.Darcs
+import Vervis.Delivery
 import Vervis.FedURI
 import Vervis.Federation.Auth
 import Vervis.Federation.Util
@@ -244,7 +247,7 @@ personOfferTicketF
     -> KeyHashid Person
     -> RemoteAuthor
     -> ActivityBody
-    -> Maybe (LocalRecipientSet, ByteString)
+    -> Maybe (RecipientRoutes, ByteString)
     -> LocalURI
     -> AP.Ticket URIMode
     -> FedURI
@@ -315,120 +318,188 @@ deckOfferTicketF
     -> KeyHashid Deck
     -> RemoteAuthor
     -> ActivityBody
-    -> Maybe (LocalRecipientSet, ByteString)
+    -> Maybe (RecipientRoutes, ByteString)
     -> LocalURI
     -> AP.Ticket URIMode
     -> FedURI
     -> ExceptT Text Handler Text
-deckOfferTicketF now recipHash author body mfwd luOffer ticket uTarget = do
+deckOfferTicketF now recipDeckHash author body mfwd luOffer ticket uTarget = do
-    error "projectOfferTicketF temporarily disabled"
 
+    -- Check input
+    recipDeckID <- decodeKeyHashid404 recipDeckHash
+    (title, desc, source) <- 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"
+        case wioRest of
+            TAM_Task deckID ->
+                if deckID == recipDeckID
+                    then return ()
+                    else throwE
+                            "Offer target is some other local deck, so I have \
+                            \no use for this Offer. Was I supposed to receive \
+                            \it?"
+            TAM_Merge _ _ ->
+                throwE
+                    "Offer target is some 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?"
+        return (wioTitle, wioDesc, wioSource)
 
-{-
+    -- Find recipient deck in DB, returning 404 if doesn't exist because we're
-    (target, summary, content, source) <- checkOfferTicket author ticket uTarget
+    -- in the deck's inbox post handler
-    mmhttp <- for (targetRelevance target) $ \ () -> lift $ runDB $ do
+    maybeHttp <- lift $ runDB $ do
-        Entity jid j <- do
+        (recipDeckActorID, recipDeckActor) <- do
-            sid <- getKeyBy404 $ UniqueSharer shrRecip
+            deck <- get404 recipDeckID
-            getBy404 $ UniqueProject prjRecip sid
+            let actorID = deckActor deck
-        a <- getJust $ projectActor j
+            (actorID,) <$> getJust actorID
-        mractid <- insertToInbox now author body (actorInbox a) luOffer False
+
-        for mractid $ \ ractid -> do
+        -- Insert the Offer to deck's inbox
-            mremotesHttpFwd <- for mfwd $ \ (localRecips, sig) -> do
+        mractid <- insertToInbox now author body (actorInbox recipDeckActor) luOffer False
+        for mractid $ \ offerID -> do
+
+            -- Forward the Offer activity to relevant local stages, and
+            -- schedule delivery for unavailable remote members of them
+            maybeHttpFwdOffer <- for mfwd $ \ (localRecips, sig) -> do
                 let sieve =
                         makeRecipientSet
                             []
-                            [ LocalPersonCollectionProjectTeam shrRecip prjRecip
+                            [LocalStageDeckFollowers recipDeckHash]
-                            , LocalPersonCollectionProjectFollowers shrRecip prjRecip
-                            ]
                 remoteRecips <-
-                    insertRemoteActivityToLocalInboxes
+                    insertRemoteActivityToLocalInboxes False offerID $
-                        False ractid $
+                        localRecipSieve' sieve False False localRecips
-                            localRecipSieve'
+                remoteRecipsHttp <-
-                                sieve False False localRecips
+                    deliverRemoteDB_D
-                (sig,) <$> deliverRemoteDB_J (actbBL body) ractid jid sig remoteRecips
+                        (actbBL body) offerID recipDeckID sig remoteRecips
-            (obiidAccept, docAccept, fwdHostsAccept, recipsAccept) <- do
+                return $
-                obiidAccept <- insertEmptyOutboxItem (actorOutbox a) now
+                    deliverRemoteHTTP_D
-                (_, ltid) <- insertLocalTicket now author (flip TicketProjectLocal jid) summary content source ractid obiidAccept
+                        now recipDeckHash (actbBL body) sig remoteRecipsHttp
+
+            -- Insert the new ticket to our DB
+            acceptID <- insertEmptyOutboxItem (actorOutbox recipDeckActor) now
+            taskID <- insertTask now title desc source recipDeckID offerID acceptID
+
+            -- Prepare an Accept activity and insert to deck's outbox
             (docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
-                    insertAccept shrRecip prjRecip author luOffer ltid obiidAccept
+                insertAcceptToOutbox taskID acceptID
+
+            -- Deliver the Accept to local recipients, and schedule delivery
+            -- for unavailable remote recipients
             knownRemoteRecipsAccept <-
                 deliverLocal'
-                        False
+                    False (LocalActorDeck recipDeckHash) recipDeckActorID
-                        (LocalActorProject shrRecip prjRecip)
+                    acceptID localRecipsAccept
-                        (actorInbox a)
+            remoteRecipsHttpAccept <-
-                        obiidAccept
+                deliverRemoteDB''
-                        localRecipsAccept
+                    fwdHostsAccept acceptID remoteRecipsAccept
-                (obiidAccept,docAccept,fwdHostsAccept,) <$>
+                    knownRemoteRecipsAccept
-                    deliverRemoteDB'' fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept
+
-            return (mremotesHttpFwd, obiidAccept, docAccept, fwdHostsAccept, recipsAccept)
+            -- Return instructions for HTTP inbox-forwarding of the Offer
-    case mmhttp of
+            -- activity, and for HTTP delivery of the Accept activity to
-        Nothing -> return "Offer target isn't me, not using"
+            -- remote recipients
-        Just mhttp ->
+            return
-            case mhttp of
+                ( maybeHttpFwdOffer
-                Nothing -> return "Activity already in my inbox, doing nothing"
+                , deliverRemoteHttp'
-                Just (mremotesHttpFwd, obiid, doc, fwdHosts, remotes) -> do
+                    fwdHostsAccept acceptID docAccept remoteRecipsHttpAccept
-                    for_ mremotesHttpFwd $ \ (sig, remotes) ->
+                )
-                        forkWorker "projectOfferTicketF inbox-forwarding" $
+
-                            deliverRemoteHTTP_J now shrRecip prjRecip (actbBL body) sig remotes
+    -- Launch asynchronous HTTP forwarding of the Offer activity and HTTP
-                    forkWorker "projectOfferTicketF Accept HTTP delivery" $
+    -- delivery of the Accept activity
-                        deliverRemoteHttp' fwdHosts obiid doc remotes
+    case maybeHttp of
-                    return $
+        Nothing -> return "I already have this activity in my inbox, doing nothing"
-                        case mremotesHttpFwd of
+        Just (maybeHttpFwdOffer, deliverHttpAccept) -> do
-                            Nothing -> "Accepted new ticket, no inbox-forwarding to do"
+            forkWorker "deckOfferTicketF Accept HTTP delivery" deliverHttpAccept
-                            Just _ -> "Accepted new ticket and ran inbox-forwarding of the Offer"
+            case maybeHttpFwdOffer of
+                Nothing -> return "Opened a ticket, no inbox-forwarding to do"
+                Just forwardHttpOffer -> do
+                    forkWorker "deckOfferTicketF inbox-forwarding" forwardHttpOffer
+                    return "Opened a ticket and ran inbox-forwarding of the Offer"
+
     where
-    targetRelevance (Left (WITProject shr prj))
+
-        | shr == shrRecip && prj == prjRecip = Just ()
+    insertTask now title desc source deckID offerID acceptID = do
-    targetRelevance _ = Nothing
+        did <- insert Discussion
-    insertAccept shr prj author luOffer ltid obiidAccept = do
+        fsid <- insert FollowerSet
+        tid <- insert Ticket
+            { ticketNumber      = Nothing
+            , ticketCreated     = now
+            , ticketTitle       = title
+            , ticketSource      = source
+            , ticketDescription = desc
+            , ticketStatus      = TSNew
+            , ticketDiscuss     = did
+            , ticketFollowers   = fsid
+            , ticketAccept      = acceptID
+            }
+        insert_ TicketAuthorRemote
+            { ticketAuthorRemoteTicket = tid
+            , ticketAuthorRemoteAuthor = remoteAuthorId author
+            , ticketAuthorRemoteOpen   = offerID
+            }
+        insert $ TicketDeck tid deckID
+
+    insertAcceptToOutbox
+        :: TicketDeckId
+        -> OutboxItemId
+        -> ReaderT SqlBackend Handler
+            ( AP.Doc AP.Activity URIMode
+            , RecipientRoutes
+            , [(Host, NonEmpty LocalURI)]
+            , [Host]
+            )
+    insertAcceptToOutbox taskID acceptID = do
         encodeRouteLocal <- getEncodeRouteLocal
         encodeRouteHome <- getEncodeRouteHome
-
         hLocal <- asksSite siteInstanceHost
 
-        obikhidAccept <- encodeKeyHashid obiidAccept
+        taskHash <- encodeKeyHashid taskID
-        ltkhid <- encodeKeyHashid ltid
+        acceptHash <- encodeKeyHashid acceptID
 
         ra <- getJust $ remoteAuthorId author
 
         let ObjURI hAuthor luAuthor = remoteAuthorURI author
 
-            audAuthor =
+            audSender =
-                AudRemote hAuthor [luAuthor] (maybeToList $ remoteActorFollowers ra)
+                AudRemote hAuthor
-            audProject =
+                    [luAuthor]
-                AudLocal []
+                    (maybeToList $ remoteActorFollowers ra)
-                    [ LocalPersonCollectionProjectTeam shr prj
+            audTracker = AudLocal [] [LocalStageDeckFollowers recipDeckHash]
-                    , LocalPersonCollectionProjectFollowers shr prj
-                    ]
 
             (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
-                collectAudience [audAuthor, audProject]
+                collectAudience [audSender, audTracker]
 
             recips = map encodeRouteHome audLocal ++ audRemote
-            doc = Doc hLocal Activity
+            doc = AP.Doc hLocal AP.Activity
-                { activityId       =
+                { AP.activityId         =
                     Just $ encodeRouteLocal $
-                        ProjectOutboxItemR shr prj obikhidAccept
+                        DeckOutboxItemR recipDeckHash acceptHash
-                , activityActor    = encodeRouteLocal $ ProjectR shr prj
+                , AP.activityActor      =
-                , activityCapability = Nothing
+                    encodeRouteLocal $ DeckR recipDeckHash
-                , activitySummary  = Nothing
+                , AP.activityCapability = Nothing
-                , activityAudience = Audience recips [] [] [] [] []
+                , AP.activitySummary    = Nothing
-                , activitySpecific = AcceptActivity Accept
+                , AP.activityAudience   = AP.Audience recips [] [] [] [] []
+                , AP.activityFulfills   = []
+                , AP.activitySpecific   = AP.AcceptActivity AP.Accept
                     { acceptObject = ObjURI hAuthor luOffer
                     , acceptResult =
-                        Just $ encodeRouteLocal $ ProjectTicketR shr prj ltkhid
+                        Just $ encodeRouteLocal $
+                            TicketR recipDeckHash taskHash
                     }
                 }
-        update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc]
+
+        update acceptID [OutboxItemActivity =. persistJSONObjectFromDoc doc]
         return (doc, recipientSet, remoteActors, fwdHosts)
--}
 
 repoOfferTicketF
     :: UTCTime
     -> KeyHashid Repo
     -> RemoteAuthor
     -> ActivityBody
-    -> Maybe (LocalRecipientSet, ByteString)
+    -> Maybe (RecipientRoutes, ByteString)
     -> LocalURI
     -> AP.Ticket URIMode
     -> FedURI
@@ -577,7 +648,7 @@ repoAddBundleF
     -> KeyHashid Repo
     -> RemoteAuthor
     -> ActivityBody
-    -> Maybe (LocalRecipientSet, ByteString)
+    -> Maybe (RecipientRoutes, ByteString)
     -> LocalURI
     -> NonEmpty (AP.Patch URIMode)
     -> FedURI
@@ -739,7 +810,7 @@ repoApplyF
     -> KeyHashid Repo
     -> RemoteAuthor
     -> ActivityBody
-    -> Maybe (LocalRecipientSet, ByteString)
+    -> Maybe (RecipientRoutes, ByteString)
     -> LocalURI
     -> FedURI
     -> FedURI
@@ -1297,7 +1368,7 @@ personOfferDepF
     -> KeyHashid Person
     -> RemoteAuthor
     -> ActivityBody
-    -> Maybe (LocalRecipientSet, ByteString)
+    -> Maybe (RecipientRoutes, ByteString)
     -> LocalURI
     -> AP.TicketDependency URIMode
     -> FedURI
@@ -1504,7 +1575,7 @@ deckOfferDepF
     -> KeyHashid Deck
     -> RemoteAuthor
     -> ActivityBody
-    -> Maybe (LocalRecipientSet, ByteString)
+    -> Maybe (RecipientRoutes, ByteString)
     -> LocalURI
     -> AP.TicketDependency URIMode
     -> FedURI
@@ -1674,7 +1745,7 @@ repoOfferDepF
     -> KeyHashid Repo
     -> RemoteAuthor
     -> ActivityBody
-    -> Maybe (LocalRecipientSet, ByteString)
+    -> Maybe (RecipientRoutes, ByteString)
     -> LocalURI
     -> AP.TicketDependency URIMode
     -> FedURI
@@ -1869,7 +1940,7 @@ deckResolveF
     -> KeyHashid Deck
     -> RemoteAuthor
     -> ActivityBody
-    -> Maybe (LocalRecipientSet, ByteString)
+    -> Maybe (RecipientRoutes, ByteString)
     -> LocalURI
     -> Resolve URIMode
     -> ExceptT Text Handler Text
@@ -2006,7 +2077,7 @@ repoResolveF
     -> KeyHashid Repo
     -> RemoteAuthor
     -> ActivityBody
-    -> Maybe (LocalRecipientSet, ByteString)
+    -> Maybe (RecipientRoutes, ByteString)
     -> LocalURI
     -> Resolve URIMode
     -> ExceptT Text Handler Text

src/Vervis/Handler/Deck.hs

@@ -97,6 +97,7 @@ import Vervis.Access
 import Vervis.API
 import Vervis.Federation.Auth
 import Vervis.Federation.Collab
+import Vervis.Federation.Ticket
 import Vervis.FedURI
 import Vervis.Form.Project
 import Vervis.Form.Ticket
@@ -187,14 +188,16 @@ postDeckInboxR recipDeckHash =
             -}
             AP.InviteActivity invite ->
                 topicInviteF now (GrantResourceDeck recipDeckHash) author body mfwd luActivity invite
-            {-
             OfferActivity (Offer obj target) ->
                 case obj of
                     OfferTicket ticket ->
-                        (,Nothing) <$> projectOfferTicketF now shrRecip prjRecip remoteAuthor body mfwd luActivity ticket target
+                        (,Nothing) <$> deckOfferTicketF now recipDeckHash author body mfwd luActivity ticket target
+                    {-
                     OfferDep dep ->
                         projectOfferDepF now shrRecip prjRecip remoteAuthor body mfwd luActivity dep target
-                    _ -> return ("Unsupported offer object type for projects", Nothing)
+                    -}
+                    _ -> return ("Unsupported offer object type for decks", Nothing)
+            {-
             ResolveActivity resolve ->
                 (,Nothing) <$> projectResolveF now shrRecip prjRecip remoteAuthor body mfwd luActivity resolve
             UndoActivity undo ->

src/Web/ActivityPub.hs

@@ -1418,19 +1418,21 @@ encodeAdd h (Add obj target)
 
 data Apply u = Apply
     { applyObject :: ObjURI u
-    , applyTarget :: ObjURI u
+    , applyTarget :: Either (ObjURI u) (Authority u, Branch u)
     }
 
 parseApply :: UriMode u => Object -> Parser (Apply u)
 parseApply o =
     Apply
         <$> o .: "object"
-        <*> o .: "target"
+        <*> (second fromDoc <$> o .:+ "target")
+    where
+    fromDoc (Doc h v) = (h, v)
 
 encodeApply :: UriMode u => Apply u -> Series
 encodeApply (Apply obj target)
     =  "object" .= obj
-    <> "target" .= target
+    <> "target" .=+ second (uncurry Doc) target
 
 data CreateObject u
     = CreateNote (Authority u) (Note u)

vervis.cabal

@@ -151,7 +151,7 @@ library
                        --Vervis.Federation.Discussion
                        --Vervis.Federation.Offer
                        --Vervis.Federation.Push
-                       --Vervis.Federation.Ticket
+                       Vervis.Federation.Ticket
                        Vervis.Federation.Util
                        Vervis.FedURI
                        -- Vervis.Field.Key