diff --git a/src/Vervis/Client.hs b/src/Vervis/Client.hs index a929cdc..94f505e 100644 --- a/src/Vervis/Client.hs +++ b/src/Vervis/Client.hs @@ -20,7 +20,7 @@ module Vervis.Client , comment --, createThread --, createReply - --, follow + , follow --, followSharer --, followProject --, followTicket @@ -28,6 +28,7 @@ module Vervis.Client , offerIssue , resolve , unresolve + , unfollow --, undoFollowSharer --, undoFollowProject --, undoFollowTicket @@ -240,37 +241,35 @@ createReply shrAuthor (TextPandocMarkdown msg) hDest recipsA recipsC context mid , noteContent = contentHtml } -} +-} follow - :: (MonadHandler m, HandlerSite m ~ App) - => ShrIdent -> ObjURI URIMode -> ObjURI URIMode -> Bool -> m (TextHtml, Audience URIMode, AP.Follow URIMode) -follow shrAuthor uObject@(ObjURI hObject luObject) uRecip hide = do - error "Temporarily disabled" - {- - summary <- - TextHtml . TL.toStrict . renderHtml <$> - withUrlRenderer - [hamlet| -

- - #{shr2text shrAuthor} - \ requested to follow # - - #{renderAuthority hObject}#{localUriPath luObject} - \. - |] - let followAP = AP.Follow - { followObject = uObject - , followContext = - if uObject == uRecip - then Nothing - else Just uRecip - , followHide = hide + :: PersonId + -> FedURI + -> ExceptT Text Handler (Maybe HTML, [Aud URIMode], AP.Follow URIMode) +follow personID uActor = do + let activity = AP.Follow + { followObject = uActor + , followContext = Nothing + , followHide = False } - audience = Audience [uRecip] [] [] [] [] [] - return (summary, audience, followAP) - -} + senderHash <- encodeKeyHashid personID + target <- do + u <- parseFedURIOld uActor + bitraverse parseLocalActorE pure u + + audActor <- + case target of + Left la -> do + lah <- VR.hashLocalActor la + return $ AudLocal [lah] [] + Right (ObjURI h lu) -> pure $ AudRemote h [lu] [] + let audience = [audActor] + + return (Nothing, audience, activity) + +{- followSharer :: (MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App) => ShrIdent -> ShrIdent -> Bool -> m (TextHtml, Audience URIMode, AP.Follow URIMode) @@ -545,6 +544,42 @@ unresolve senderHash uTicket = do return (Nothing, audience, AP.Undo uResolve) +unfollow + :: PersonId + -> FedURI + -> ExceptT Text Handler (Maybe HTML, [Aud URIMode], AP.Undo URIMode) +unfollow personID uActor = do + encodeRouteHome <- getEncodeRouteHome + senderHash <- encodeKeyHashid personID + target <- do + u <- parseFedURIOld uActor + bitraverse parseLocalActorE pure u + followID <- runDBExcept $ do + meActorID <- lift $ personActor <$> getJust personID + case target of + Left byk -> do + themActorID <- localActorID <$> getLocalActorEntityE byk "No such local acto in DB" + theirFollowerSetID <- lift $ actorFollowers <$> getJust themActorID + mf <- lift $ getValBy $ UniqueFollow meActorID theirFollowerSetID + followFollow <$> + fromMaybeE mf "I don't have a record of following this local actor, so idk which Follow activity to Undo" + Right u -> do + mf <- lift $ getValBy $ UniqueFollowRemote meActorID u + followRemoteFollow <$> + fromMaybeE mf "I don't have a record of following this remote actor, so idk which Follow activity to Undo" + uFollow <- + encodeRouteHome . PersonOutboxItemR senderHash <$> encodeKeyHashid followID + + audActor <- + case target of + Left la -> do + lah <- VR.hashLocalActor la + return $ AudLocal [lah] [] + Right (ObjURI h lu) -> pure $ AudRemote h [lu] [] + let audience = [audActor] + + return (Nothing, audience, AP.Undo uFollow) + {- undoFollow :: (MonadUnliftIO m, MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App) diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index ac9c33d..71cade3 100644 --- a/src/Vervis/Foundation.hs +++ b/src/Vervis/Foundation.hs @@ -876,9 +876,6 @@ instance YesodBreadcrumbs App where PersonMessageR p m -> ("Message #" <> keyHashidText m, Just $ PersonR p) - PersonFollowR _ -> ("", Nothing) - PersonUnfollowR _ -> ("", Nothing) - PersonStampR p k -> ("Stamp #" <> keyHashidText k, Just $ PersonR p) GroupNewR -> ("New Team", Just HomeR) @@ -1055,3 +1052,11 @@ instance YesodBreadcrumbs App where RepoErrboxR r -> ("Errbox", Just $ RepoR r) DeckErrboxR d -> ("Errbox", Just $ DeckR d) LoomErrboxR l -> ("Errbox", Just $ LoomR l) + + RemoteActorsR -> ("Remote Actors", Just HomeR) + RemoteActorR k -> (T.pack $ show $ fromSqlKey k, Just RemoteActorsR) + + FollowLocalR _ -> ("", Nothing) + FollowRemoteR _ -> ("", Nothing) + UnfollowLocalR _ -> ("", Nothing) + UnfollowRemoteR _ -> ("", Nothing) diff --git a/src/Vervis/Handler/Client.hs b/src/Vervis/Handler/Client.hs index 6c2c539..2627531 100644 --- a/src/Vervis/Handler/Client.hs +++ b/src/Vervis/Handler/Client.hs @@ -52,6 +52,14 @@ module Vervis.Handler.Client , postPublishResolveR , postAcceptInviteR + + , getRemoteActorsR + , getRemoteActorR + + , postFollowLocalR + , postFollowRemoteR + , postUnfollowLocalR + , postUnfollowRemoteR ) where @@ -118,6 +126,7 @@ import Vervis.Recipient import Vervis.Settings import Vervis.Web.Actor import Vervis.Widget +import Vervis.Widget.Person import Vervis.Widget.Tracker import qualified Vervis.Client as C @@ -1694,3 +1703,139 @@ postAcceptInviteR fulfillsHash = do Left e -> setMessage $ toHtml e Right _acceptID -> setMessage "Accept sent" redirect HomeR + +getRemoteActorsR :: Handler Html +getRemoteActorsR = do + actors <- runDB $ E.select $ E.from $ \ (actor `E.InnerJoin` object `E.InnerJoin` inztance) -> do + E.on $ object E.^. RemoteObjectInstance E.==. inztance E.^. InstanceId + E.on $ actor E.^. RemoteActorIdent E.==. object E.^. RemoteObjectId + E.orderBy [E.desc $ actor E.^. RemoteActorId] + return + ( inztance + , object + , actor + ) + defaultLayout $(widgetFile "remote-actors") + +getRemoteActorR :: RemoteActorId -> Handler Html +getRemoteActorR actorID = do + maybePersonID <- maybeAuthId + (linkInfo@(Instance h, RemoteObject _ lu, RemoteActor _ _ luInbox mluFollowers errorSince typ), maybePermits) <- runDB $ do + actor <- get404 actorID + linkInfo <- do + object <- getJust $ remoteActorIdent actor + inztance <- getJust $ remoteObjectInstance object + return (inztance, object, actor) + maybePermits <- + for maybePersonID $ \ personID -> + getPermitsForResource personID $ Right actorID + return (linkInfo, maybePermits) + defaultLayout $(widgetFile "remote-actor") + +postFollowLocalR :: ActorId -> Handler () +postFollowLocalR actorID = do + personEntity@(Entity personID person) <- requireAuth + personHash <- encodeKeyHashid personID + encodeRouteHome <- getEncodeRouteHome + + result <- runExceptT $ do + byk <- lift $ runDB $ do + _ <- get404 actorID + getLocalActor actorID + (actorR, uActor) <- lift $ do + byh <- VR.hashLocalActor byk + let actorR = renderLocalActor byh + return (actorR, encodeRouteHome actorR) + (maybeSummary, audience, follow) <- C.follow personID uActor + (localRecips, remoteRecips, fwdHosts, action) <- + C.makeServerInput Nothing maybeSummary audience $ + AP.FollowActivity follow + (actorR,) <$> + handleViaActor + personID Nothing localRecips remoteRecips fwdHosts action + + case result of + Left e -> do + setMessage $ toHtml e + redirect HomeR + Right (actorR, _followID) -> do + setMessage "Follow sent" + redirect actorR + +postFollowRemoteR :: RemoteActorId -> Handler () +postFollowRemoteR actorID = do + personEntity@(Entity personID person) <- requireAuth + personHash <- encodeKeyHashid personID + + result <- runExceptT $ do + uActor <- lift $ runDB $ do + actor <- get404 actorID + getRemoteActorURI actor + (maybeSummary, audience, follow) <- C.follow personID uActor + (localRecips, remoteRecips, fwdHosts, action) <- + C.makeServerInput Nothing maybeSummary audience $ + AP.FollowActivity follow + handleViaActor + personID Nothing localRecips remoteRecips fwdHosts action + + case result of + Left e -> do + setMessage $ toHtml e + redirect HomeR + Right _followID -> do + setMessage "Follow sent" + redirect $ RemoteActorR actorID + +postUnfollowLocalR :: ActorId -> Handler () +postUnfollowLocalR actorID = do + personEntity@(Entity personID person) <- requireAuth + personHash <- encodeKeyHashid personID + encodeRouteHome <- getEncodeRouteHome + + result <- runExceptT $ do + byk <- lift $ runDB $ do + _ <- get404 actorID + getLocalActor actorID + (actorR, uActor) <- lift $ do + byh <- VR.hashLocalActor byk + let actorR = renderLocalActor byh + return (actorR, encodeRouteHome actorR) + (maybeSummary, audience, undo) <- C.unfollow personID uActor + (localRecips, remoteRecips, fwdHosts, action) <- + C.makeServerInput Nothing maybeSummary audience $ + AP.UndoActivity undo + (actorR,) <$> + handleViaActor + personID Nothing localRecips remoteRecips fwdHosts action + + case result of + Left e -> do + setMessage $ toHtml e + redirect HomeR + Right (actorR, _undoID) -> do + setMessage "Undo sent" + redirect actorR + +postUnfollowRemoteR :: RemoteActorId -> Handler () +postUnfollowRemoteR actorID = do + personEntity@(Entity personID person) <- requireAuth + personHash <- encodeKeyHashid personID + + result <- runExceptT $ do + uActor <- lift $ runDB $ do + actor <- get404 actorID + getRemoteActorURI actor + (maybeSummary, audience, undo) <- C.unfollow personID uActor + (localRecips, remoteRecips, fwdHosts, action) <- + C.makeServerInput Nothing maybeSummary audience $ + AP.UndoActivity undo + handleViaActor + personID Nothing localRecips remoteRecips fwdHosts action + + case result of + Left e -> do + setMessage $ toHtml e + redirect HomeR + Right _undoID -> do + setMessage "Undo sent" + redirect $ RemoteActorR actorID diff --git a/src/Vervis/Handler/Loom.hs b/src/Vervis/Handler/Loom.hs index ce99a12..bed6eb9 100644 --- a/src/Vervis/Handler/Loom.hs +++ b/src/Vervis/Handler/Loom.hs @@ -94,6 +94,7 @@ import Vervis.Settings import Vervis.Ticket import Vervis.TicketFilter import Vervis.Web.Actor +import Vervis.Widget.Person import Vervis.Widget.Ticket import Vervis.Widget.Tracker diff --git a/src/Vervis/Handler/Person.hs b/src/Vervis/Handler/Person.hs index 23f0d02..f7ae1ab 100644 --- a/src/Vervis/Handler/Person.hs +++ b/src/Vervis/Handler/Person.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2016, 2018, 2019, 2022, 2023 + - Written in 2016, 2018, 2019, 2022, 2023, 2024 - by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. @@ -27,9 +27,6 @@ module Vervis.Handler.Person , getSshKeyR , getPersonMessageR - , postPersonFollowR - , postPersonUnfollowR - , getPersonStampR ) where @@ -127,11 +124,6 @@ getPersonR personHash = do , AP.actorSummary = Just $ actorDesc actor } } - followButton = - followW - (PersonFollowR personHash) - (PersonUnfollowR personHash) - (actorFollowers actor) let ep = Entity personID person secure <- getSecure @@ -301,11 +293,5 @@ getPersonMessageR getPersonMessageR personHash localMessageHash = serveMessage personHash localMessageHash -postPersonFollowR :: KeyHashid Person -> Handler () -postPersonFollowR _ = error "Temporarily disabled" - -postPersonUnfollowR :: KeyHashid Person -> Handler () -postPersonUnfollowR _ = error "Temporarily disabled" - getPersonStampR :: KeyHashid Person -> KeyHashid SigKey -> Handler TypedContent getPersonStampR = servePerActorKey personActor LocalActorPerson diff --git a/src/Vervis/Web/Darcs.hs b/src/Vervis/Web/Darcs.hs index c6fcc40..eef2e0a 100644 --- a/src/Vervis/Web/Darcs.hs +++ b/src/Vervis/Web/Darcs.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2016, 2018, 2019, 2020, 2022 + - Written in 2016, 2018, 2019, 2020, 2022, 2024 - by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. @@ -112,9 +112,6 @@ getDarcsRepoSource repository actor repo dir loomIDs = do Just s -> return s addStylesheet $ HighlightStyleR style $(widgetFile "repo/source-darcs") - where - followButton = - followW (RepoFollowR repo) (RepoUnfollowR repo) (actorFollowers actor) getDarcsRepoChanges :: KeyHashid Repo -> Handler TypedContent getDarcsRepoChanges repo = do diff --git a/src/Vervis/Web/Git.hs b/src/Vervis/Web/Git.hs index 6aab254..bd351dd 100644 --- a/src/Vervis/Web/Git.hs +++ b/src/Vervis/Web/Git.hs @@ -127,9 +127,6 @@ getGitRepoSource repository actor repo ref dir loomIDs = do Just s -> return s addStylesheet $ HighlightStyleR style $(widgetFile "repo/source-git") - where - followButton = - followW (RepoFollowR repo) (RepoUnfollowR repo) (actorFollowers actor) {- getGitRepoBranch :: ShrIdent -> RpIdent -> Text -> Handler TypedContent diff --git a/src/Vervis/Widget/Person.hs b/src/Vervis/Widget/Person.hs index 9231148..a3dbbff 100644 --- a/src/Vervis/Widget/Person.hs +++ b/src/Vervis/Widget/Person.hs @@ -1,6 +1,7 @@ {- This file is part of Vervis. - - - Written in 2016, 2019, 2022, 2023 by fr33domlover . + - Written in 2016, 2019, 2022, 2023, 2024 + - by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -17,11 +18,13 @@ module Vervis.Widget.Person ( personLinkW , personLinkFedW , followW + , followW' , personNavW ) where import Data.Foldable +import Data.Maybe import Database.Persist import Network.HTTP.Types.Method import Yesod.Core @@ -38,6 +41,7 @@ import Database.Persist.Local import Vervis.Foundation import Vervis.Model import Vervis.Model.Ident +import Vervis.Persist.Actor import Vervis.Settings import Vervis.Widget @@ -84,6 +88,63 @@ followW followRoute unfollowRoute fsid = do Nothing -> buttonW POST "Follow" followRoute Just _ -> buttonW POST "Unfollow" unfollowRoute +followW' :: Either ActorId RemoteActorId -> Widget +followW' (Left actorID) = do + maybeUser <- maybeVerifiedAuth + for_ maybeUser $ \ (Entity userID user) -> do + (alreadyFollowing, alreadyRequest) <- + handlerToWidget $ runDB $ do + fsid <- actorFollowers <$> getJust actorID + (,) <$> (isJust <$> getBy (UniqueFollow (personActor user) fsid)) + <*> (isJust <$> getBy (UniqueFollowRequest (personActor user) fsid)) + if alreadyFollowing + then + [whamlet| +