S2S: Store relevant Push activities in recipient's inbox

Before, Push activities were being ignored by all inboxes. I just forgot to add
code to handle them. Now, person inboxes accept them if they're about a
relevant repo (i.e. a repo of which the user is a remote follower; remote
collaboration would be relevant too, but it's not implemented yet).

src/Vervis/Federation.hs

@@ -97,6 +97,7 @@ import Vervis.ActorKey
 import Vervis.Federation.Auth
 import Vervis.Federation.Discussion
 import Vervis.Federation.Offer
+import Vervis.Federation.Push
 import Vervis.Federation.Ticket
 import Vervis.Foundation
 import Vervis.Model
@@ -271,6 +272,8 @@ handleSharerInbox now shrRecip (ActivityAuthRemote author) body =
             sharerFollowF shrRecip now author body follow
         OfferActivity offer ->
             sharerOfferTicketF now shrRecip author body offer
+        PushActivity push ->
+            sharerPushF shrRecip now author body push
         RejectActivity reject ->
             sharerRejectF shrRecip now author body reject
         UndoActivity undo ->

src/Vervis/Federation/Push.hs

@@ -0,0 +1,111 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2019 by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ Copying is an act of love. Please copy, reuse and share.
+ -
+ - The author(s) have dedicated all copyright and related and neighboring
+ - rights to this software to the public domain worldwide. This software is
+ - distributed without any warranty.
+ -
+ - You should have received a copy of the CC0 Public Domain Dedication along
+ - with this software. If not, see
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+module Vervis.Federation.Push
+    ( sharerPushF
+    )
+where
+
+--import Control.Exception hiding (Handler)
+--import Control.Monad
+--import Control.Monad.Logger.CallStack
+import Control.Monad.Trans.Class
+import Control.Monad.Trans.Except
+--import Control.Monad.Trans.Maybe
+--import Data.Aeson
+--import Data.Bifunctor
+--import Data.Foldable
+--import Data.Function
+--import Data.List (nub, union)
+--import Data.List.NonEmpty (NonEmpty (..))
+import Data.Maybe
+import Data.Text (Text)
+--import Data.Time.Calendar
+import Data.Time.Clock
+--import Data.Traversable
+import Database.Persist
+--import Text.Blaze.Html (preEscapedToHtml)
+--import Text.Blaze.Html.Renderer.Text
+--import Yesod.Core hiding (logError, logWarn, logInfo, logDebug)
+--import Yesod.Core.Handler
+import Yesod.Persist.Core
+
+--import qualified Data.List.NonEmpty as NE
+--import qualified Data.List.Ordered as LO
+--import qualified Data.Text as T
+--import qualified Data.Text.Lazy as TL
+
+import Database.Persist.JSON
+import Network.FedURI
+import Web.ActivityPub
+--import Yesod.ActivityPub
+import Yesod.FedURI
+--import Yesod.Hashids
+--import Yesod.MonadSite
+
+import Control.Monad.Trans.Except.Local
+--import Data.Tuple.Local
+import Database.Persist.Local
+import Yesod.Persist.Local
+
+--import Vervis.ActivityPub
+import Vervis.FedURI
+import Vervis.Federation.Auth
+import Vervis.Foundation
+import Vervis.Model
+import Vervis.Model.Ident
+
+sharerPushF
+    :: ShrIdent
+    -> UTCTime
+    -> RemoteAuthor
+    -> ActivityBody
+    -> Push URIMode
+    -> ExceptT Text Handler Text
+sharerPushF shr now author body push = do
+    luPush <- fromMaybeE (activityId $ actbActivity body) "Push without 'id'"
+    lift $ runDB $ do
+        Entity pidRecip recip <- do
+            sid <- getKeyBy404 $ UniqueSharer shr
+            getBy404 $ UniquePersonIdent sid
+        let hAuthor = objUriAuthority $ remoteAuthorURI author
+            luRepo = pushContext push
+        mfr <- getBy $ UniqueFollowRemote pidRecip (ObjURI hAuthor luRepo)
+        if isNothing mfr
+            then return "Got a Push to a repo unrelated to me; ignoring"
+            else do
+                mractid <- insertToInbox luPush $ personInbox recip
+                encodeRouteLocal <- getEncodeRouteLocal
+                let me = localUriPath $ encodeRouteLocal $ SharerR shr
+                return $
+                    case mractid of
+                        Nothing ->
+                            "Activity already exists in inbox of " <> me
+                        Just ractid ->
+                            "Activity inserted to inbox of " <> me
+    where
+    insertToInbox luPush ibidRecip = do
+        let iidAuthor = remoteAuthorInstance author
+            jsonObj = persistJSONFromBL $ actbBL body
+            ract = RemoteActivity iidAuthor luPush jsonObj now
+        ractid <- either entityKey id <$> insertBy' ract
+        ibiid <- insert $ InboxItem True
+        mibrid <- insertUnique $ InboxItemRemote ibidRecip ractid ibiid
+        encodeRouteLocal <- getEncodeRouteLocal
+        case mibrid of
+            Nothing -> do
+                delete ibiid
+                return Nothing
+            Just _ -> return $ Just ractid

src/Vervis/Handler/Repo.hs

@@ -562,6 +562,7 @@ postPostReceiveR = do
                         case mbranch of
                             Nothing -> RepoR shr rp
                             Just b -> RepoBranchR shr rp b
+                , pushContext      = encodeRouteLocal $ RepoR shr rp
                 , pushHashBefore   = mbefore
                 , pushHashAfter    = after
                 }

src/Web/ActivityPub.hs

@@ -1124,6 +1124,7 @@ data Push u = Push
     , pushCommitsFirst :: Maybe (NonEmpty (Commit u))
     , pushCommitsTotal :: Int
     , pushTarget       :: LocalURI
+    , pushContext      :: LocalURI
     , pushHashBefore   :: Maybe Text
     , pushHashAfter    :: Maybe Text
     }
@@ -1136,11 +1137,12 @@ parsePush a o = do
         <*> (traverse (traverse $ withAuthorityT a . parseObject) =<< c .:? "earlyItems")
         <*> c .: "totalItems"
         <*> withAuthorityO a (o .: "target")
+        <*> withAuthorityO a (o .: "context")
         <*> o .:? "hashBefore"
         <*> o .:? "hashAfter"
 
 encodePush :: UriMode u => Authority u -> Push u -> Series
-encodePush a (Push lateCommits earlyCommits total target before after)
+encodePush a (Push lateCommits earlyCommits total target context before after)
     =  "object"     `pair` pairs
             (  "type"       .= ("OrderedCollection" :: Text)
             <> pair "items" (objectList lateCommits)
@@ -1148,6 +1150,7 @@ encodePush a (Push lateCommits earlyCommits total target before after)
             <> "totalItems" .= total
             )
     <> "target"     .= ObjURI a target
+    <> "context"    .= ObjURI a context
     <> "hashBefore" .=? before
     <> "hashAfter"  .=? after
     where

vervis.cabal

@@ -132,6 +132,7 @@ library
                        Vervis.Federation.Auth
                        Vervis.Federation.Discussion
                        Vervis.Federation.Offer
+                       Vervis.Federation.Push
                        Vervis.Federation.Ticket
                        Vervis.FedURI
                        Vervis.Field.Key