Implement S2S Follow for sharers, projects and repos

This commit is contained in:
fr33domlover 2019-09-16 15:18:18 +00:00
parent 525a722439
commit 612dfa1fce
5 changed files with 422 additions and 67 deletions

View file

@ -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

View file

@ -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 ()

View file

@ -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

View file

@ -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

View file

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