diff --git a/config/routes b/config/routes index b5519df..79a1dc4 100644 --- a/config/routes +++ b/config/routes @@ -64,6 +64,7 @@ /s/#ShrIdent/outbox/#OutboxItemKeyHashid SharerOutboxItemR GET /s/#ShrIdent/followers SharerFollowersR GET /s/#ShrIdent/follow SharerFollowR POST +/s/#ShrIdent/unfollow SharerUnfollowR POST /p PeopleR GET @@ -93,6 +94,7 @@ /s/#ShrIdent/r/#RpIdent/followers RepoFollowersR GET /s/#ShrIdent/r/#RpIdent/edit RepoEditR GET /s/#ShrIdent/r/#RpIdent/follow RepoFollowR POST +/s/#ShrIdent/r/#RpIdent/unfollow RepoUnfollowR POST /s/#ShrIdent/r/#RpIdent/s/+Texts RepoSourceR GET /s/#ShrIdent/r/#RpIdent/c RepoHeadChangesR GET /s/#ShrIdent/r/#RpIdent/b/#Text RepoBranchR GET @@ -117,6 +119,7 @@ /s/#ShrIdent/p/#PrjIdent/followers ProjectFollowersR GET /s/#ShrIdent/p/#PrjIdent/edit ProjectEditR GET /s/#ShrIdent/p/#PrjIdent/follow ProjectFollowR POST +/s/#ShrIdent/p/#PrjIdent/unfollow ProjectUnfollowR POST /s/#ShrIdent/p/#PrjIdent/d ProjectDevsR GET POST /s/#ShrIdent/p/#PrjIdent/d/!new ProjectDevNewR GET /s/#ShrIdent/p/#PrjIdent/d/#ShrIdent ProjectDevR GET DELETE POST @@ -153,6 +156,7 @@ /s/#ShrIdent/p/#PrjIdent/t/#Int/assign TicketAssignR GET POST /s/#ShrIdent/p/#PrjIdent/t/#Int/unassign TicketUnassignR POST /s/#ShrIdent/p/#PrjIdent/t/#Int/follow TicketFollowR POST +/s/#ShrIdent/p/#PrjIdent/t/#Int/unfollow TicketUnfollowR POST /s/#ShrIdent/p/#PrjIdent/tcr ClaimRequestsProjectR GET /s/#ShrIdent/p/#PrjIdent/t/#Int/cr ClaimRequestsTicketR GET POST /s/#ShrIdent/p/#PrjIdent/t/#Int/cr/new ClaimRequestNewR GET diff --git a/src/Vervis/API.hs b/src/Vervis/API.hs index 185873a..73feb61 100644 --- a/src/Vervis/API.hs +++ b/src/Vervis/API.hs @@ -17,6 +17,7 @@ module Vervis.API ( createNoteC , followC , offerTicketC + , undoC , pushCommitsC , getFollowersCollection ) @@ -99,8 +100,8 @@ import Database.Persist.Local import Yesod.Persist.Local import Vervis.ActivityPub +import Vervis.ActivityPub.Recipient import Vervis.ActorKey -import Vervis.API.Recipient import Vervis.FedURI import Vervis.Foundation import Vervis.Model @@ -883,6 +884,85 @@ offerTicketC shrUser summary audience offer@(Offer ticket uTarget) = runExceptT insert_ $ InboxItemLocal ibid obiid ibiid return remotes +undoC + :: ShrIdent + -> TextHtml + -> Audience URIMode + -> Undo URIMode + -> Handler (Either Text OutboxItemId) +undoC shrUser summary audience undo@(Undo luObject) = runExceptT $ do + (localRecips, remoteRecips) <- do + mrecips <- parseAudience audience + fromMaybeE mrecips "Follow with no recipients" + federation <- asksSite $ appFederation . appSettings + unless (federation || null remoteRecips) $ + throwE "Federation disabled, but remote recipients specified" + route <- + fromMaybeE + (decodeRouteLocal luObject) + "Undo object isn't a valid route" + obiidOriginal <- case route of + SharerOutboxItemR shr obikhid + | shr == shrUser -> + decodeKeyHashidE obikhid "Undo object invalid obikhid" + _ -> throwE "Undo object isn't actor's outbox item route" + let dont = Authority "dont-do.any-forwarding" Nothing + (obiidUndo, doc, remotesHttp) <- runDBExcept $ do + Entity _pidAuthor personAuthor <- lift $ getAuthor shrUser + obi <- do + mobi <- lift $ get obiidOriginal + fromMaybeE mobi "Undo object obiid doesn't exist in DB" + unless (outboxItemOutbox obi == personOutbox personAuthor) $ + throwE "Undo object obiid belongs to different actor" + lift $ do + deleteFollow obiidOriginal + deleteFollowRemote obiidOriginal + deleteFollowRemoteRequest obiidOriginal + let obidAuthor = personOutbox personAuthor + (obiidUndo, doc, luUndo) <- insertUndoToOutbox obidAuthor + let ibidAuthor = personInbox personAuthor + fsidAuthor = personFollowers personAuthor + knownRemotes <- deliverLocal shrUser ibidAuthor fsidAuthor obiidUndo localRecips + remotesHttp <- deliverRemoteDB' dont obiidUndo remoteRecips knownRemotes + return (obiidUndo, doc, remotesHttp) + lift $ forkWorker "undoC: Outbox POST handler: async HTTP delivery" $ deliverRemoteHttp dont obiidUndo doc remotesHttp + return obiidUndo + where + getAuthor shr = do + sid <- getKeyBy404 $ UniqueSharer shr + getBy404 $ UniquePersonIdent sid + deleteFollow obiid = do + mfid <- getKeyBy $ UniqueFollowFollow obiid + traverse_ delete mfid + deleteFollowRemote obiid = do + mfrid <- getKeyBy $ UniqueFollowRemoteFollow obiid + traverse_ delete mfrid + deleteFollowRemoteRequest obiid = do + mfrrid <- getKeyBy $ UniqueFollowRemoteRequestActivity obiid + traverse_ delete mfrrid + insertUndoToOutbox obid = do + hLocal <- asksSite siteInstanceHost + encodeRouteLocal <- getEncodeRouteLocal + let activity mluAct = Doc hLocal Activity + { activityId = mluAct + , activityActor = encodeRouteLocal $ SharerR shrUser + , activitySummary = Just summary + , activityAudience = audience + , activitySpecific = UndoActivity undo + } + now <- liftIO getCurrentTime + obiid <- insert OutboxItem + { outboxItemOutbox = obid + , outboxItemActivity = + persistJSONObjectFromDoc $ activity Nothing + , outboxItemPublished = now + } + obikhid <- encodeKeyHashid obiid + let luAct = encodeRouteLocal $ SharerOutboxItemR shrUser obikhid + doc = activity $ Just luAct + update obiid [OutboxItemActivity =. persistJSONObjectFromDoc doc] + return (obiid, doc, luAct) + pushCommitsC :: (Entity Person, Sharer) -> Html diff --git a/src/Vervis/ActivityPub.hs b/src/Vervis/ActivityPub.hs index f8bec5b..2a6c701 100644 --- a/src/Vervis/ActivityPub.hs +++ b/src/Vervis/ActivityPub.hs @@ -20,7 +20,6 @@ module Vervis.ActivityPub , parseParent , runDBExcept , getLocalParentMessageId - , concatRecipients , getPersonOrGroupId , getTicketTeam , getProjectTeam @@ -41,6 +40,7 @@ module Vervis.ActivityPub , deliverRemoteDB' , deliverRemoteHttp , serveCommit + , deliverLocal ) where @@ -80,6 +80,7 @@ import Yesod.Persist.Core import qualified Data.ByteString.Lazy as BL import qualified Data.CaseInsensitive as CI import qualified Data.List.NonEmpty as NE +import qualified Data.List as L import qualified Data.List.Ordered as LO import qualified Data.Text as T import qualified Data.Text.Lazy as TL @@ -104,6 +105,7 @@ import Data.List.NonEmpty.Local import Data.Tuple.Local import Database.Persist.Local +import Vervis.ActivityPub.Recipient import Vervis.FedURI import Vervis.Foundation import Vervis.Model @@ -190,9 +192,6 @@ getLocalParentMessageId did shr lmid = do throwE "Local parent belongs to a different discussion" return mid -concatRecipients :: Audience u -> [ObjURI u] -concatRecipients (Audience to bto cc bcc gen _) = concat [to, bto, cc, bcc, gen] - getPersonOrGroupId :: SharerId -> AppDB (Either PersonId GroupId) getPersonOrGroupId sid = do mpid <- getKeyBy $ UniquePersonIdent sid @@ -693,3 +692,74 @@ serveCommit shr rp ref patch parents = do } makeAuthor encodeRouteHome (Just sharer) _ = Right $ encodeRouteHome $ SharerR $ sharerIdent sharer + +-- | Given a list of local recipients, which may include actors and +-- collections, +-- +-- * Insert activity to inboxes of actors +-- * If the author's follower collection is listed, insert activity to the +-- local members and return the remote members +-- * Ignore other collections +deliverLocal + :: ShrIdent + -> InboxId + -> FollowerSetId + -> Key OutboxItem + -> [(ShrIdent, LocalSharerRelatedSet)] + -> AppDB + [ ( (InstanceId, Host) + , NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime) + ) + ] +deliverLocal shrAuthor ibidAuthor fsidAuthor obiid recips = do + (pidsFollowers, remotesFollowers) <- + if authorFollowers shrAuthor recips + then getFollowers fsidAuthor + else return ([], []) + ibidsFollowers <- + map (personInbox . entityVal) <$> + selectList [PersonId <-. pidsFollowers] [Asc PersonInbox] + ibidsSharer <- L.delete ibidAuthor <$> getSharerInboxes recips + ibidsOther <- concat <$> traverse getOtherInboxes recips + let ibids = LO.union ibidsFollowers ibidsSharer ++ ibidsOther + ibiids <- insertMany $ replicate (length ibids) $ InboxItem True + insertMany_ $ + map (\ (ibid, ibiid) -> InboxItemLocal ibid obiid ibiid) + (zip ibids ibiids) + return remotesFollowers + where + getSharerInboxes sharers = do + let shrs = + [shr | (shr, s) <- sharers + , localRecipSharer $ localRecipSharerDirect s + ] + sids <- selectKeysList [SharerIdent <-. shrs] [] + map (personInbox . entityVal) <$> selectList [PersonIdent <-. sids] [Asc PersonInbox] + getOtherInboxes (shr, LocalSharerRelatedSet _ projects repos) = do + msid <- getKeyBy $ UniqueSharer shr + case msid of + Nothing -> return [] + Just sid -> + (++) + <$> getProjectInboxes sid projects + <*> getRepoInboxes sid repos + where + getProjectInboxes sid projects = + let prjs = + [prj | (prj, j) <- projects + , localRecipProject $ localRecipProjectDirect j + ] + in map (projectInbox . entityVal) <$> + selectList [ProjectSharer ==. sid, ProjectIdent <-. prjs] [] + getRepoInboxes sid repos = + let rps = + [rp | (rp, r) <- repos + , localRecipRepo $ localRecipRepoDirect r + ] + in map (repoInbox . entityVal) <$> + selectList [RepoSharer ==. sid, RepoIdent <-. rps] [] + authorFollowers shr lrset = + case lookup shr lrset of + Just s + | localRecipSharerFollowers $ localRecipSharerDirect s -> True + _ -> False diff --git a/src/Vervis/API/Recipient.hs b/src/Vervis/ActivityPub/Recipient.hs similarity index 98% rename from src/Vervis/API/Recipient.hs rename to src/Vervis/ActivityPub/Recipient.hs index b24c509..7455d1c 100644 --- a/src/Vervis/API/Recipient.hs +++ b/src/Vervis/ActivityPub/Recipient.hs @@ -13,14 +13,17 @@ - . -} -module Vervis.API.Recipient +module Vervis.ActivityPub.Recipient ( LocalActor (..) , LocalTicketDirectSet (..) , LocalProjectDirectSet (..) , LocalProjectRelatedSet (..) + , LocalRepoDirectSet (..) + , LocalRepoRelatedSet (..) , LocalSharerDirectSet (..) , LocalSharerRelatedSet (..) , LocalRecipientSet + , concatRecipients , parseAudience , actorRecips ) @@ -49,11 +52,14 @@ import Yesod.MonadSite import Data.List.NonEmpty.Local -import Vervis.ActivityPub import Vervis.FedURI import Vervis.Foundation import Vervis.Model.Ident +concatRecipients :: Audience u -> [ObjURI u] +concatRecipients (Audience to bto cc bcc gen _) = + concat [to, bto, cc, bcc, gen] + ------------------------------------------------------------------------------- -- Actor and collection-of-persons types -- diff --git a/src/Vervis/Client.hs b/src/Vervis/Client.hs index d0dcf06..afc14cc 100644 --- a/src/Vervis/Client.hs +++ b/src/Vervis/Client.hs @@ -22,11 +22,17 @@ module Vervis.Client , followTicket , followRepo , offerTicket + , undoFollowSharer + , undoFollowProject + , undoFollowTicket + , undoFollowRepo ) where import Control.Monad.Trans.Except +import Control.Monad.Trans.Reader import Database.Persist +import Database.Persist.Sql import Data.Text (Text) import Text.Blaze.Html (preEscapedToHtml) import Text.Blaze.Html.Renderer.Text @@ -40,6 +46,7 @@ import qualified Data.Text.Lazy as TL import Network.FedURI import Web.ActivityPub hiding (Follow) +import Yesod.ActivityPub import Yesod.FedURI import Yesod.Hashids import Yesod.MonadSite @@ -47,8 +54,10 @@ import Yesod.RenderSource import qualified Web.ActivityPub as AP +import Control.Monad.Trans.Except.Local import Database.Persist.Local +import Vervis.ActivityPub import Vervis.FedURI import Vervis.Foundation import Vervis.Model @@ -242,3 +251,120 @@ offerTicket shrAuthor (TextHtml title) (TextPandocMarkdown desc) shr prj = runEx , audienceNonActors = map encodeRouteHome recipsC } return (summary, audience, offer) + +undoFollow + :: (MonadUnliftIO m, MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App) + => ShrIdent + -> PersonId + -> ExceptT Text (ReaderT SqlBackend m) FollowerSetId + -> Text + -> Route App + -> Route App + -> m (Either Text (TextHtml, Audience URIMode, Undo URIMode)) +undoFollow shrAuthor pidAuthor getFsid typ objRoute recipRoute = runExceptT $ do + encodeRouteLocal <- getEncodeRouteLocal + encodeRouteHome <- getEncodeRouteHome + obiidFollow <- runDBExcept $ do + fsid <- getFsid + mf <- lift $ getValBy $ UniqueFollow pidAuthor fsid + followFollow <$> fromMaybeE mf ("Not following this " <> typ) + obikhidFollow <- encodeKeyHashid obiidFollow + summary <- do + hLocal <- asksSite siteInstanceHost + TextHtml . TL.toStrict . renderHtml <$> + withUrlRenderer + [hamlet| +

+ + #{shr2text shrAuthor} + \ unfollowed # + + #{renderAuthority hLocal}#{localUriPath $ encodeRouteLocal objRoute} + \. + |] + let undo = Undo + { undoObject = + encodeRouteLocal $ SharerOutboxItemR shrAuthor obikhidFollow + } + audience = Audience [encodeRouteHome recipRoute] [] [] [] [] [] + return (summary, audience, undo) + +undoFollowSharer + :: (MonadUnliftIO m, MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App) + => ShrIdent + -> PersonId + -> ShrIdent + -> m (Either Text (TextHtml, Audience URIMode, Undo URIMode)) +undoFollowSharer shrAuthor pidAuthor shrFollowee = + undoFollow shrAuthor pidAuthor getFsid "sharer" objRoute objRoute + where + objRoute = SharerR shrFollowee + getFsid = do + sidFollowee <- do + msid <- lift $ getKeyBy $ UniqueSharer shrFollowee + fromMaybeE msid "No such local sharer" + mp <- lift $ getValBy $ UniquePersonIdent sidFollowee + personFollowers <$> + fromMaybeE mp "Unfollow target local sharer isn't a person" + +undoFollowProject + :: (MonadUnliftIO m, MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App) + => ShrIdent + -> PersonId + -> ShrIdent + -> PrjIdent + -> m (Either Text (TextHtml, Audience URIMode, Undo URIMode)) +undoFollowProject shrAuthor pidAuthor shrFollowee prjFollowee = + undoFollow shrAuthor pidAuthor getFsid "project" objRoute objRoute + where + objRoute = ProjectR shrFollowee prjFollowee + getFsid = do + sidFollowee <- do + msid <- lift $ getKeyBy $ UniqueSharer shrFollowee + fromMaybeE msid "No such local sharer" + mj <- lift $ getValBy $ UniqueProject prjFollowee sidFollowee + projectFollowers <$> + fromMaybeE mj "Unfollow target no such local project" + +undoFollowTicket + :: (MonadUnliftIO m, MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App) + => ShrIdent + -> PersonId + -> ShrIdent + -> PrjIdent + -> Int + -> m (Either Text (TextHtml, Audience URIMode, Undo URIMode)) +undoFollowTicket shrAuthor pidAuthor shrFollowee prjFollowee numFollowee = + undoFollow shrAuthor pidAuthor getFsid "project" objRoute recipRoute + where + objRoute = TicketR shrFollowee prjFollowee numFollowee + recipRoute = ProjectR shrFollowee prjFollowee + getFsid = do + sid <- do + msid <- lift $ getKeyBy $ UniqueSharer shrFollowee + fromMaybeE msid "No such local sharer" + jid <- do + mjid <- lift $ getKeyBy $ UniqueProject prjFollowee sid + fromMaybeE mjid "No such local project" + mt <- lift $ getValBy $ UniqueTicket jid numFollowee + ticketFollowers <$> + fromMaybeE mt "Unfollow target no such local ticket" + +undoFollowRepo + :: (MonadUnliftIO m, MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App) + => ShrIdent + -> PersonId + -> ShrIdent + -> RpIdent + -> m (Either Text (TextHtml, Audience URIMode, Undo URIMode)) +undoFollowRepo shrAuthor pidAuthor shrFollowee rpFollowee = + undoFollow shrAuthor pidAuthor getFsid "repo" objRoute objRoute + where + objRoute = RepoR shrFollowee rpFollowee + getFsid = do + sidFollowee <- do + msid <- lift $ getKeyBy $ UniqueSharer shrFollowee + fromMaybeE msid "No such local sharer" + mr <- lift $ getValBy $ UniqueRepo rpFollowee sidFollowee + repoFollowers <$> + fromMaybeE mr "Unfollow target no such local repo" diff --git a/src/Vervis/Federation/Discussion.hs b/src/Vervis/Federation/Discussion.hs index 1dc9067..c1aff8d 100644 --- a/src/Vervis/Federation/Discussion.hs +++ b/src/Vervis/Federation/Discussion.hs @@ -19,85 +19,54 @@ module Vervis.Federation.Discussion ) where ---import Control.Applicative ---import Control.Concurrent.MVar ---import Control.Concurrent.STM.TVar import Control.Exception hiding (Handler, try) import Control.Monad import Control.Monad.Logger.CallStack import Control.Monad.Trans.Class import Control.Monad.Trans.Except import Control.Monad.Trans.Maybe ---import Control.Monad.Trans.Reader ---import Crypto.Hash ---import Data.Aeson import Data.Bifunctor import Data.ByteString (ByteString) ---import Data.Either import Data.Foldable import Data.Function import Data.List (sort, deleteBy, nub, union, unionBy, partition) import Data.List.NonEmpty (NonEmpty (..), nonEmpty) import Data.Maybe ---import Data.Semigroup import Data.Text (Text) import Data.Text.Encoding import Data.Time.Clock ---import Data.Time.Units import Data.Traversable ---import Data.Tuple import Database.Persist ---import Database.Persist.Sql hiding (deleteBy) ---import Network.HTTP.Client ---import Network.HTTP.Types.Header ---import Network.HTTP.Types.URI ---import Network.TLS hiding (SHA256) ---import UnliftIO.Exception (try) import Yesod.Core hiding (logError, logWarn, logInfo, logDebug) import Yesod.Persist.Core import qualified Data.ByteString.Lazy as BL import qualified Data.CaseInsensitive as CI ---import qualified Data.List as L import qualified Data.List.NonEmpty as NE ---import qualified Data.List.Ordered as LO import qualified Data.Text as T import qualified Database.Esqueleto as E ---import qualified Network.Wai as W ---import Data.Time.Interval ---import Network.HTTP.Signature hiding (requestHeaders) import Yesod.HttpSignature ---import Crypto.PublicVerifKey import Database.Persist.JSON import Network.FedURI import Network.HTTP.Digest import Web.ActivityPub import Yesod.ActivityPub ---import Yesod.Auth.Unverified import Yesod.FedURI ---import Yesod.Hashids ---import Yesod.MonadSite import Control.Monad.Trans.Except.Local ---import Data.Aeson.Local ---import Data.Either.Local ---import Data.List.Local ---import Data.List.NonEmpty.Local ---import Data.Maybe.Local import Data.Tuple.Local import Database.Persist.Local import Yesod.Persist.Local import Vervis.ActivityPub ---import Vervis.ActorKey +import Vervis.ActivityPub.Recipient import Vervis.FedURI import Vervis.Federation.Auth import Vervis.Foundation import Vervis.Model import Vervis.Model.Ident ---import Vervis.RemoteActorStore import Vervis.Settings sharerCreateNoteF diff --git a/src/Vervis/Federation/Ticket.hs b/src/Vervis/Federation/Ticket.hs index 10d358f..eb2e353 100644 --- a/src/Vervis/Federation/Ticket.hs +++ b/src/Vervis/Federation/Ticket.hs @@ -63,6 +63,7 @@ import Database.Persist.Local import Yesod.Persist.Local import Vervis.ActivityPub +import Vervis.ActivityPub.Recipient import Vervis.FedURI import Vervis.Federation.Auth import Vervis.Foundation diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index 4ddfa5c..dfa8c6a 100644 --- a/src/Vervis/Foundation.hs +++ b/src/Vervis/Foundation.hs @@ -300,6 +300,7 @@ instance Yesod App where (NotificationsR shr , _ ) -> person shr (SharerOutboxR shr , True) -> person shr (SharerFollowR shr , True) -> personAny + (SharerUnfollowR shr , True) -> personAny (GroupsR , True) -> personAny (GroupNewR , _ ) -> personAny @@ -324,6 +325,7 @@ instance Yesod App where (RepoR shar _ , True) -> person shar (RepoEditR shr _rp , _ ) -> person shr (RepoFollowR _shr _rp , True) -> personAny + (RepoUnfollowR _shr _rp , True) -> personAny (RepoDevsR shr _rp , _ ) -> person shr (RepoDevNewR shr _rp , _ ) -> person shr (RepoDevR shr _rp _dev , _ ) -> person shr @@ -333,6 +335,7 @@ instance Yesod App where (ProjectR shr _prj , True) -> person shr (ProjectEditR shr _prj , _ ) -> person shr (ProjectFollowR _shr _prj , _ ) -> personAny + (ProjectUnfollowR _shr _prj , _ ) -> personAny (ProjectDevsR shr _prj , _ ) -> person shr (ProjectDevNewR shr _prj , _ ) -> person shr (ProjectDevR shr _prj _dev , _ ) -> person shr @@ -366,6 +369,7 @@ instance Yesod App where (TicketAssignR s j _ , _ ) -> projOp ProjOpAssignTicket s j (TicketUnassignR s j _ , _ ) -> projOp ProjOpUnassignTicket s j (TicketFollowR _ _ _ , True) -> personAny + (TicketUnfollowR _ _ _ , True) -> personAny (ClaimRequestsTicketR s j _, True) -> projOp ProjOpRequestTicket s j (ClaimRequestNewR s j _ , _ ) -> projOp ProjOpRequestTicket s j (TicketDiscussionR _ _ _ , True) -> personAny diff --git a/src/Vervis/Handler/Client.hs b/src/Vervis/Handler/Client.hs index 412e3ed..5f1c7cf 100644 --- a/src/Vervis/Handler/Client.hs +++ b/src/Vervis/Handler/Client.hs @@ -16,12 +16,20 @@ module Vervis.Handler.Client ( getPublishR , postSharerOutboxR + , postSharerFollowR , postProjectFollowR , postTicketFollowR , postRepoFollowR + + , postSharerUnfollowR + , postProjectUnfollowR + , postTicketUnfollowR + , postRepoUnfollowR + , getNotificationsR , postNotificationsR + , postTicketsR ) where @@ -199,11 +207,14 @@ activityWidget shr widget1 enctype1 widget2 enctype2 widget3 enctype3 = |] -getUserShrIdent :: Handler ShrIdent -getUserShrIdent = do - Entity _ p <- requireVerifiedAuth +getUser :: Handler (ShrIdent, PersonId) +getUser = do + Entity pid p <- requireVerifiedAuth s <- runDB $ getJust $ personIdent p - return $ sharerIdent s + return (sharerIdent s, pid) + +getUserShrIdent :: Handler ShrIdent +getUserShrIdent = fst <$> getUser getPublishR :: Handler Html getPublishR = do @@ -389,6 +400,57 @@ postRepoFollowR shrObject rpObject = do setFollowMessage shrAuthor eid redirect $ RepoR shrObject rpObject +setUnfollowMessage :: ShrIdent -> Either Text OutboxItemId -> Handler () +setUnfollowMessage _ (Left err) = setMessage $ toHtml err +setUnfollowMessage shr (Right obiid) = do + obikhid <- encodeKeyHashid obiid + setMessage =<< + withUrlRenderer + [hamlet| + + Unfollow request published! + |] + +postSharerUnfollowR :: ShrIdent -> Handler () +postSharerUnfollowR shrFollowee = do + (shrAuthor, pidAuthor) <- getUser + eid <- runExceptT $ do + (summary, audience, undo) <- + ExceptT $ undoFollowSharer shrAuthor pidAuthor shrFollowee + ExceptT $ undoC shrAuthor summary audience undo + setUnfollowMessage shrAuthor eid + redirect $ SharerR shrFollowee + +postProjectUnfollowR :: ShrIdent -> PrjIdent -> Handler () +postProjectUnfollowR shrFollowee prjFollowee = do + (shrAuthor, pidAuthor) <- getUser + eid <- runExceptT $ do + (summary, audience, undo) <- + ExceptT $ undoFollowProject shrAuthor pidAuthor shrFollowee prjFollowee + ExceptT $ undoC shrAuthor summary audience undo + setUnfollowMessage shrAuthor eid + redirect $ ProjectR shrFollowee prjFollowee + +postTicketUnfollowR :: ShrIdent -> PrjIdent -> Int -> Handler () +postTicketUnfollowR shrFollowee prjFollowee numFollowee = do + (shrAuthor, pidAuthor) <- getUser + eid <- runExceptT $ do + (summary, audience, undo) <- + ExceptT $ undoFollowTicket shrAuthor pidAuthor shrFollowee prjFollowee numFollowee + ExceptT $ undoC shrAuthor summary audience undo + setUnfollowMessage shrAuthor eid + redirect $ TicketR shrFollowee prjFollowee numFollowee + +postRepoUnfollowR :: ShrIdent -> RpIdent -> Handler () +postRepoUnfollowR shrFollowee rpFollowee = do + (shrAuthor, pidAuthor) <- getUser + eid <- runExceptT $ do + (summary, audience, undo) <- + ExceptT $ undoFollowRepo shrAuthor pidAuthor shrFollowee rpFollowee + ExceptT $ undoC shrAuthor summary audience undo + setUnfollowMessage shrAuthor eid + redirect $ RepoR shrFollowee rpFollowee + notificationForm :: Maybe (Maybe (InboxItemId, Bool)) -> Form (Maybe (InboxItemId, Bool)) notificationForm defs = renderDivs $ mk <$> aopt hiddenField (name "Inbox Item ID#") (fmap fst <$> defs) diff --git a/src/Vervis/Handler/Person.hs b/src/Vervis/Handler/Person.hs index 673453b..83e6ea0 100644 --- a/src/Vervis/Handler/Person.hs +++ b/src/Vervis/Handler/Person.hs @@ -148,4 +148,7 @@ getPerson shr sharer person = do provideHtmlAndAP personAP $(widgetFile "person") where followButton = - followW (SharerFollowR shr) (return $ personFollowers person) + followW + (SharerFollowR shr) + (SharerUnfollowR shr) + (return $ personFollowers person) diff --git a/src/Vervis/Handler/Project.hs b/src/Vervis/Handler/Project.hs index 7176987..37e5796 100644 --- a/src/Vervis/Handler/Project.hs +++ b/src/Vervis/Handler/Project.hs @@ -163,6 +163,7 @@ getProjectR shar proj = do followButton = followW (ProjectFollowR shar proj) + (ProjectUnfollowR shar proj) (return $ projectFollowers project) provideHtmlAndAP projectAP $(widgetFile "project/one") diff --git a/src/Vervis/Handler/Repo/Darcs.hs b/src/Vervis/Handler/Repo/Darcs.hs index 7da4dba..f96801f 100644 --- a/src/Vervis/Handler/Repo/Darcs.hs +++ b/src/Vervis/Handler/Repo/Darcs.hs @@ -98,7 +98,10 @@ getDarcsRepoSource repository user repo dir = do $(widgetFile "repo/source-darcs") where followButton = - followW (RepoFollowR user repo) (return $ repoFollowers repository) + followW + (RepoFollowR user repo) + (RepoUnfollowR user repo) + (return $ repoFollowers repository) getDarcsRepoHeadChanges :: ShrIdent -> RpIdent -> Handler TypedContent getDarcsRepoHeadChanges shar repo = do diff --git a/src/Vervis/Handler/Repo/Git.hs b/src/Vervis/Handler/Repo/Git.hs index 484a47d..ea66913 100644 --- a/src/Vervis/Handler/Repo/Git.hs +++ b/src/Vervis/Handler/Repo/Git.hs @@ -113,7 +113,10 @@ getGitRepoSource repository user repo ref dir = do $(widgetFile "repo/source-git") where followButton = - followW (RepoFollowR user repo) (return $ repoFollowers repository) + followW + (RepoFollowR user repo) + (RepoUnfollowR user repo) + (return $ repoFollowers repository) getGitRepoHeadChanges :: Repo -> ShrIdent -> RpIdent -> Handler TypedContent getGitRepoHeadChanges repository shar repo = diff --git a/src/Vervis/Handler/Ticket.hs b/src/Vervis/Handler/Ticket.hs index 2c921ab..6d71f76 100644 --- a/src/Vervis/Handler/Ticket.hs +++ b/src/Vervis/Handler/Ticket.hs @@ -295,6 +295,7 @@ getTicketR shar proj num = do let followButton = followW (TicketFollowR shar proj num) + (TicketUnfollowR shar proj num) (return $ ticketFollowers ticket) in $(widgetFile "ticket/one") diff --git a/src/Vervis/Widget/Sharer.hs b/src/Vervis/Widget/Sharer.hs index 7693187..2453e90 100644 --- a/src/Vervis/Widget/Sharer.hs +++ b/src/Vervis/Widget/Sharer.hs @@ -59,8 +59,8 @@ sharerLinkFedW (Right (inztance, actor)) = where uActor = ObjURI (instanceHost inztance) (remoteActorIdent actor) -followW :: Route App -> AppDB FollowerSetId -> Widget -followW followRoute getFsid = do +followW :: Route App -> Route App -> AppDB FollowerSetId -> Widget +followW followRoute unfollowRoute getFsid = do mpid <- maybeVerifiedAuthId for_ mpid $ \ pid -> do mfollow <- handlerToWidget $ runDB $ do @@ -68,7 +68,4 @@ followW followRoute getFsid = do getValBy $ UniqueFollow pid fsid case mfollow of Nothing -> buttonW POST "Follow" followRoute - Just _ -> - [whamlet| -

[Following] - |] + Just _ -> buttonW POST "Unfollow" unfollowRoute diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index 9338cd2..2f0cefc 100644 --- a/src/Web/ActivityPub.hs +++ b/src/Web/ActivityPub.hs @@ -1155,6 +1155,7 @@ instance ActivityPub Activity where activityType (OfferActivity _) = "Offer" activityType (PushActivity _) = "Push" activityType (RejectActivity _) = "Reject" + activityType (UndoActivity _) = "Undo" encodeSpecific h _ (AcceptActivity a) = encodeAccept h a encodeSpecific h u (CreateActivity a) = encodeCreate h u a encodeSpecific _ _ (FollowActivity a) = encodeFollow a diff --git a/vervis.cabal b/vervis.cabal index 4020890..e15326d 100644 --- a/vervis.cabal +++ b/vervis.cabal @@ -115,9 +115,9 @@ library Vervis.Access Vervis.ActivityPub + Vervis.ActivityPub.Recipient Vervis.ActorKey Vervis.API - Vervis.API.Recipient Vervis.Application Vervis.Avatar Vervis.BinaryBody