Implement S2S Follow for sharers, projects and repos

src/Vervis/API.hs

@@ -573,7 +573,7 @@ followC shrUser summary audience follow@(AP.Follow uObject hide) = runExceptT $
         return (obiid, doc, luAct)
 
     deliverFollowLocal pidAuthor fsid unread obiid ibidRecip = do
-        insert_ $ Follow pidAuthor fsid True True
+        insert_ $ Follow pidAuthor fsid True (not hide)
         ibiid <- insert $ InboxItem unread
         insert_ $ InboxItemLocal ibidRecip obiid ibiid
 

src/Vervis/Federation.hs

@@ -96,6 +96,7 @@ import Vervis.ActivityPub
 import Vervis.ActorKey
 import Vervis.Federation.Auth
 import Vervis.Federation.Discussion
+import Vervis.Federation.Offer
 import Vervis.Federation.Ticket
 import Vervis.Foundation
 import Vervis.Model
@@ -219,13 +220,15 @@ handleSharerInbox _now shrRecip (ActivityAuthLocalProject jidAuthor) body = do
 handleSharerInbox now shrRecip (ActivityAuthRemote author) body =
     case activitySpecific $ actbActivity body of
         AcceptActivity accept ->
-            sharerAcceptOfferTicketF now shrRecip author body accept
+            sharerAcceptF shrRecip now author body accept
         CreateActivity (Create note) ->
             sharerCreateNoteF now shrRecip author body note
+        FollowActivity follow ->
+            sharerFollowF shrRecip now author body follow
         OfferActivity offer ->
             sharerOfferTicketF now shrRecip author body offer
         RejectActivity reject ->
-            sharerRejectOfferTicketF now shrRecip author body reject
+            sharerRejectF shrRecip now author body reject
         _ -> return "Unsupported activity type"
 
 handleProjectInbox
@@ -250,6 +253,8 @@ handleProjectInbox now shrRecip prjRecip auth body = do
     case activitySpecific $ actbActivity body of
         CreateActivity (Create note) ->
             projectCreateNoteF now shrRecip prjRecip remoteAuthor body note
+        FollowActivity follow ->
+            projectFollowF shrRecip prjRecip now remoteAuthor body follow
         OfferActivity offer ->
             projectOfferTicketF now shrRecip prjRecip remoteAuthor body offer
         _ -> return "Unsupported activity type"
@@ -274,6 +279,8 @@ handleRepoInbox now shrRecip rpRecip auth body = do
                     T.pack (show $ fromSqlKey jid)
             ActivityAuthRemote ra -> return ra
     case activitySpecific $ actbActivity body of
+        FollowActivity follow ->
+            repoFollowF shrRecip rpRecip now remoteAuthor body follow
         _ -> return "Unsupported activity type"
 
 fixRunningDeliveries :: (MonadIO m, MonadLogger m, IsSqlBackend backend) => ReaderT backend m ()

src/Vervis/Federation/Offer.hs

@@ -0,0 +1,411 @@
+{- 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.Offer
+    ( sharerAcceptF
+
+    , sharerRejectF
+
+    , sharerFollowF
+    , projectFollowF
+    , repoFollowF
+    )
+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 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 hiding (Ticket (..), Follow)
+import Yesod.ActivityPub
+import Yesod.FedURI
+import Yesod.Hashids
+import Yesod.MonadSite
+
+import qualified Web.ActivityPub as AP
+
+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
+import Vervis.Model.Ticket
+
+acceptF
+    :: AppDB InboxId
+    -> Route App
+    -> UTCTime
+    -> RemoteAuthor
+    -> ActivityBody
+    -> Accept URIMode
+    -> ExceptT Text Handler Text
+acceptF getIbid route now author body (Accept _uOffer _luTicket) = do
+    luAccept <-
+        fromMaybeE (activityId $ actbActivity body) "Accept without 'id'"
+    lift $ runDB $ do
+        ibidRecip <- getIbid
+        insertToInbox luAccept ibidRecip
+    where
+    insertToInbox luAccept ibidRecip = do
+        let iidAuthor = remoteAuthorInstance author
+            jsonObj = persistJSONFromBL $ actbBL body
+            ract = RemoteActivity iidAuthor luAccept jsonObj now
+        ractid <- either entityKey id <$> insertBy' ract
+        ibiid <- insert $ InboxItem True
+        mibrid <- insertUnique $ InboxItemRemote ibidRecip ractid ibiid
+        encodeRouteLocal <- getEncodeRouteLocal
+        let recip = localUriPath $ encodeRouteLocal route
+        case mibrid of
+            Nothing -> do
+                delete ibiid
+                return $ "Activity already exists in inbox of " <> recip
+            Just _ -> return $ "Activity inserted to inbox of " <> recip
+
+sharerAcceptF
+    :: ShrIdent
+    -> UTCTime
+    -> RemoteAuthor
+    -> ActivityBody
+    -> Accept URIMode
+    -> ExceptT Text Handler Text
+sharerAcceptF shr = acceptF getIbid route
+    where
+    route = SharerR shr
+    getIbid = do
+            sid <- getKeyBy404 $ UniqueSharer shr
+            p <- getValBy404 $ UniquePersonIdent sid
+            return $ personInbox p
+
+{-
+projectAcceptF
+    :: ShrIdent
+    -> PrjIdent
+    -> UTCTime
+    -> RemoteAuthor
+    -> ActivityBody
+    -> Accept URIMode
+    -> ExceptT Text Handler Text
+projectAcceptF shr prj = acceptF getIbid route
+    where
+    route = ProjectR shr prj
+    getIbid = do
+            sid <- getKeyBy404 $ UniqueSharer shr
+            j <- getValBy404 $ UniqueProject prj sid
+            return $ projectInbox j
+
+repoAcceptF
+    :: ShrIdent
+    -> RpIdent
+    -> UTCTime
+    -> RemoteAuthor
+    -> ActivityBody
+    -> Accept URIMode
+    -> ExceptT Text Handler Text
+repoAcceptF shr rp = acceptF getIbid route
+    where
+    route = RepoR shr rp
+    getIbid = do
+            sid <- getKeyBy404 $ UniqueSharer shr
+            r <- getValBy404 $ UniqueRepo rp sid
+            return $ repoInbox r
+-}
+
+rejectF
+    :: AppDB InboxId
+    -> Route App
+    -> UTCTime
+    -> RemoteAuthor
+    -> ActivityBody
+    -> Reject URIMode
+    -> ExceptT Text Handler Text
+rejectF getIbid route now author body (Reject _uOffer) = do
+    luReject <-
+        fromMaybeE (activityId $ actbActivity body) "Reject without 'id'"
+    lift $ runDB $ do
+        ibidRecip <- getIbid
+        insertToInbox luReject ibidRecip
+    where
+    insertToInbox luReject ibidRecip = do
+        let iidAuthor = remoteAuthorInstance author
+            jsonObj = persistJSONFromBL $ actbBL body
+            ract = RemoteActivity iidAuthor luReject jsonObj now
+        ractid <- either entityKey id <$> insertBy' ract
+        ibiid <- insert $ InboxItem True
+        mibrid <- insertUnique $ InboxItemRemote ibidRecip ractid ibiid
+        encodeRouteLocal <- getEncodeRouteLocal
+        let recip = localUriPath $ encodeRouteLocal route
+        case mibrid of
+            Nothing -> do
+                delete ibiid
+                return $ "Activity already exists in inbox of " <> recip
+            Just _ -> return $ "Activity inserted to inbox of " <> recip
+
+sharerRejectF
+    :: ShrIdent
+    -> UTCTime
+    -> RemoteAuthor
+    -> ActivityBody
+    -> Reject URIMode
+    -> ExceptT Text Handler Text
+sharerRejectF shr = rejectF getIbid route
+    where
+    route = SharerR shr
+    getIbid = do
+        sid <- getKeyBy404 $ UniqueSharer shr
+        p <- getValBy404 $ UniquePersonIdent sid
+        return $ personInbox p
+
+{-
+projectRejectF
+    :: ShrIdent
+    -> PrjIdent
+    -> UTCTime
+    -> RemoteAuthor
+    -> ActivityBody
+    -> Reject URIMode
+    -> ExceptT Text Handler Text
+projectRejectF shr prj = rejectF getIbid route
+    where
+    route = ProjectR shr prj
+    getIbid = do
+        sid <- getKeyBy404 $ UniqueSharer shr
+        j <- getValBy404 $ UniqueProject prj sid
+        return $ projectInbox j
+
+repoRejectF
+    :: ShrIdent
+    -> RpIdent
+    -> UTCTime
+    -> RemoteAuthor
+    -> ActivityBody
+    -> Reject URIMode
+    -> ExceptT Text Handler Text
+repoRejectF shr rp = rejectF getIbid route
+    where
+    route = RepoR shr rp
+    getIbid = do
+        sid <- getKeyBy404 $ UniqueSharer shr
+        r <- getValBy404 $ UniqueRepo rp sid
+        return $ repoInbox r
+-}
+
+followF
+    :: AppDB a
+    -> Route App
+    -> (a -> InboxId)
+    -> (a -> OutboxId)
+    -> (a -> FollowerSetId)
+    -> (KeyHashid OutboxItem -> Route App)
+    -> UTCTime
+    -> RemoteAuthor
+    -> ActivityBody
+    -> AP.Follow URIMode
+    -> ExceptT Text Handler Text
+followF
+    getRecip recipRoute recipInbox recipOutbox recipFollowers outboxItemRoute
+    now author body (AP.Follow (ObjURI hObj luObj) hide) = do
+        me <- do
+            local <- hostIsLocal hObj
+            return $
+                case decodeRouteLocal luObj of
+                    Just r | local && r == recipRoute -> True
+                    _ -> False
+        if me
+            then do
+                luFollow <-
+                    fromMaybeE
+                        (activityId $ actbActivity body)
+                        "Follow without 'id'"
+                emsg <- lift $ runDB $ do
+                    recip <- getRecip
+                    newItem <- insertToInbox luFollow $ recipInbox recip
+                    if newItem
+                        then do
+                            newFollow <- insertFollow $ recipFollowers recip
+                            if newFollow
+                                then Right <$> do
+                                    (obiid, doc) <-
+                                        insertAcceptToOutbox
+                                            luFollow
+                                            (recipOutbox recip)
+                                    let raidAuthor = remoteAuthorId author
+                                    ra <- getJust raidAuthor
+                                    let raInfo = (raidAuthor, remoteActorIdent ra, remoteActorInbox ra, remoteActorErrorSince ra)
+                                        iidAuthor = remoteAuthorInstance author
+                                        hAuthor = objUriAuthority $ remoteAuthorURI author
+                                        hostSection = ((iidAuthor, hAuthor), raInfo :| [])
+                                    (obiid, doc,) <$> deliverRemoteDB' dont obiid [] [hostSection]
+                                else return $ Left "You're already a follower of me"
+                        else return $ Left "Activity already exists in inbox, not using"
+                case emsg of
+                    Left msg -> return msg
+                    Right (obiid, doc, remotesHttp) -> do
+                        forkWorker "followF: Accept delivery" $
+                            deliverRemoteHttp dont obiid doc remotesHttp
+                        return "Follow request accepted"
+            else return "Follow object unrelated to me, ignoring activity"
+    where
+    dont = Authority "dont-do.any-forwarding" Nothing
+
+    insertToInbox luFollow ibidRecip = do
+        let iidAuthor = remoteAuthorInstance author
+            jsonObj = persistJSONFromBL $ actbBL body
+            ract = RemoteActivity iidAuthor luFollow jsonObj now
+        ractid <- either entityKey id <$> insertBy' ract
+        ibiid <- insert $ InboxItem True
+        mibrid <- insertUnique $ InboxItemRemote ibidRecip ractid ibiid
+        case mibrid of
+            Nothing -> do
+                delete ibiid
+                return False
+            Just _ -> return True
+
+    insertFollow fsid = do
+        let raid = remoteAuthorId author
+        mrfid <- insertUnique $ RemoteFollow raid fsid True (not hide)
+        return $ isJust mrfid
+
+    insertAcceptToOutbox luFollow obidRecip = do
+        now <- liftIO getCurrentTime
+        let uAuthor@(ObjURI hAuthor _) = remoteAuthorURI author
+        encodeRouteLocal <- getEncodeRouteLocal
+        hLocal <- asksSite siteInstanceHost
+        let recipPath = localUriPath $ encodeRouteLocal recipRoute
+        summary <-
+            TextHtml . TL.toStrict . renderHtml <$>
+                withUrlRenderer
+                    [hamlet|
+                        <p>
+                          <a href="#{renderObjURI $ remoteAuthorURI author}">
+                            (?)
+                          's follow request accepted by #
+                          <a href=@{recipRoute}>
+                            #{renderAuthority hLocal}#{recipPath}
+                          .
+                    |]
+        let accept luAct = Doc hLocal Activity
+                { activityId       = luAct
+                , activityActor    = encodeRouteLocal recipRoute
+                , activitySummary  = Just summary
+                , activityAudience = Audience [uAuthor] [] [] [] [] []
+                , activitySpecific = AcceptActivity Accept
+                    { acceptObject = ObjURI hAuthor luFollow
+                    , acceptResult = Nothing
+                    }
+                }
+        obiid <- insert OutboxItem
+            { outboxItemOutbox    = obidRecip
+            , outboxItemActivity  = persistJSONObjectFromDoc $ accept Nothing
+            , outboxItemPublished = now
+            }
+        obikhid <- encodeKeyHashid obiid
+        let luAct = encodeRouteLocal $ outboxItemRoute obikhid
+            doc = accept $ Just luAct
+        update obiid [OutboxItemActivity =. persistJSONObjectFromDoc doc]
+        return (obiid, doc)
+
+sharerFollowF
+    :: ShrIdent
+    -> UTCTime
+    -> RemoteAuthor
+    -> ActivityBody
+    -> AP.Follow URIMode
+    -> ExceptT Text Handler Text
+sharerFollowF shr =
+    followF
+        getRecip
+        (SharerR shr)
+        personInbox
+        personOutbox
+        personFollowers
+        (SharerOutboxItemR shr)
+    where
+    getRecip = do
+        sid <- getKeyBy404 $ UniqueSharer shr
+        getValBy404 $ UniquePersonIdent sid
+
+projectFollowF
+    :: ShrIdent
+    -> PrjIdent
+    -> UTCTime
+    -> RemoteAuthor
+    -> ActivityBody
+    -> AP.Follow URIMode
+    -> ExceptT Text Handler Text
+projectFollowF shr prj =
+    followF
+        getRecip
+        (ProjectR shr prj)
+        projectInbox
+        projectOutbox
+        projectFollowers
+        (ProjectOutboxItemR shr prj)
+    where
+    getRecip = do
+        sid <- getKeyBy404 $ UniqueSharer shr
+        getValBy404 $ UniqueProject prj sid
+
+repoFollowF
+    :: ShrIdent
+    -> RpIdent
+    -> UTCTime
+    -> RemoteAuthor
+    -> ActivityBody
+    -> AP.Follow URIMode
+    -> ExceptT Text Handler Text
+repoFollowF shr rp =
+    followF
+        getRecip
+        (RepoR shr rp)
+        repoInbox
+        repoOutbox
+        repoFollowers
+        (RepoOutboxItemR shr rp)
+    where
+    getRecip = do
+        sid <- getKeyBy404 $ UniqueSharer shr
+        getValBy404 $ UniqueRepo rp sid

src/Vervis/Federation/Ticket.hs

@@ -15,8 +15,6 @@
 
 module Vervis.Federation.Ticket
     ( sharerOfferTicketF
-    , sharerAcceptOfferTicketF
-    , sharerRejectOfferTicketF
     , projectOfferTicketF
     )
 where
@@ -133,68 +131,6 @@ sharerOfferTicketF now shrRecip author body (Offer ticket uTarget) = do
                 return $ "Activity already exists in inbox of /s/" <> recip
             Just _ -> return $ "Activity inserted to inbox of /s/" <> recip
 
-sharerAcceptOfferTicketF
-    :: UTCTime
-    -> ShrIdent
-    -> RemoteAuthor
-    -> ActivityBody
-    -> Accept URIMode
-    -> ExceptT Text Handler Text
-sharerAcceptOfferTicketF now shrRecip author body (Accept _uOffer _luTicket) = do
-    luAccept <-
-        fromMaybeE (activityId $ actbActivity body) "Accept without 'id'"
-    lift $ runDB $ do
-        ibidRecip <- do
-            sid <- getKeyBy404 $ UniqueSharer shrRecip
-            p <- getValBy404 $ UniquePersonIdent sid
-            return $ personInbox p
-        insertToInbox luAccept ibidRecip
-    where
-    insertToInbox luAccept ibidRecip = do
-        let iidAuthor = remoteAuthorInstance author
-            jsonObj = persistJSONFromBL $ actbBL body
-            ract = RemoteActivity iidAuthor luAccept jsonObj now
-        ractid <- either entityKey id <$> insertBy' ract
-        ibiid <- insert $ InboxItem True
-        mibrid <- insertUnique $ InboxItemRemote ibidRecip ractid ibiid
-        let recip = shr2text shrRecip
-        case mibrid of
-            Nothing -> do
-                delete ibiid
-                return $ "Activity already exists in inbox of /s/" <> recip
-            Just _ -> return $ "Activity inserted to inbox of /s/" <> recip
-
-sharerRejectOfferTicketF
-    :: UTCTime
-    -> ShrIdent
-    -> RemoteAuthor
-    -> ActivityBody
-    -> Reject URIMode
-    -> ExceptT Text Handler Text
-sharerRejectOfferTicketF now shrRecip author body (Reject _uOffer) = do
-    luReject <-
-        fromMaybeE (activityId $ actbActivity body) "Reject without 'id'"
-    lift $ runDB $ do
-        ibidRecip <- do
-            sid <- getKeyBy404 $ UniqueSharer shrRecip
-            p <- getValBy404 $ UniquePersonIdent sid
-            return $ personInbox p
-        insertToInbox luReject ibidRecip
-    where
-    insertToInbox luReject ibidRecip = do
-        let iidAuthor = remoteAuthorInstance author
-            jsonObj = persistJSONFromBL $ actbBL body
-            ract = RemoteActivity iidAuthor luReject jsonObj now
-        ractid <- either entityKey id <$> insertBy' ract
-        ibiid <- insert $ InboxItem True
-        mibrid <- insertUnique $ InboxItemRemote ibidRecip ractid ibiid
-        let recip = shr2text shrRecip
-        case mibrid of
-            Nothing -> do
-                delete ibiid
-                return $ "Activity already exists in inbox of /s/" <> recip
-            Just _ -> return $ "Activity inserted to inbox of /s/" <> recip
-
 data OfferTicketRecipColl
     = OfferTicketRecipProjectFollowers
     | OfferTicketRecipProjectTeam

vervis.cabal

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