diff --git a/src/Vervis/API.hs b/src/Vervis/API.hs index ca99ac7..261ccbc 100644 --- a/src/Vervis/API.hs +++ b/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 diff --git a/src/Vervis/Federation.hs b/src/Vervis/Federation.hs index 0f17a70..1eb4edb 100644 --- a/src/Vervis/Federation.hs +++ b/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 () diff --git a/src/Vervis/Federation/Offer.hs b/src/Vervis/Federation/Offer.hs new file mode 100644 index 0000000..9419bd8 --- /dev/null +++ b/src/Vervis/Federation/Offer.hs @@ -0,0 +1,411 @@ +{- This file is part of Vervis. + - + - Written in 2019 by fr33domlover . + - + - ♡ 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 + - . + -} + +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| +

+ + (?) + 's follow request accepted by # + + #{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 diff --git a/src/Vervis/Federation/Ticket.hs b/src/Vervis/Federation/Ticket.hs index a2da78c..924d2bf 100644 --- a/src/Vervis/Federation/Ticket.hs +++ b/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 diff --git a/vervis.cabal b/vervis.cabal index 385d988..5d41a7b 100644 --- a/vervis.cabal +++ b/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