From bc379a864f4ffe45daffaa0b37f1a82480f53000 Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Sat, 19 Oct 2019 08:15:48 +0000 Subject: [PATCH] Provide 'following' collections and link in page header --- config/routes | 1 + src/Vervis/Handler/Person.hs | 1 + src/Vervis/Handler/Project.hs | 1 + src/Vervis/Handler/Repo.hs | 1 + src/Vervis/Handler/Sharer.hs | 77 +++++++++++++++++++++++++++++++++ src/Web/ActivityPub.hs | 5 ++- templates/default-layout.hamlet | 3 ++ 7 files changed, 88 insertions(+), 1 deletion(-) diff --git a/config/routes b/config/routes index 1a76223..01d2f2d 100644 --- a/config/routes +++ b/config/routes @@ -63,6 +63,7 @@ /s/#ShrIdent/outbox SharerOutboxR GET POST /s/#ShrIdent/outbox/#OutboxItemKeyHashid SharerOutboxItemR GET /s/#ShrIdent/followers SharerFollowersR GET +/s/#ShrIdent/following SharerFollowingR GET /s/#ShrIdent/follow SharerFollowR POST /s/#ShrIdent/unfollow SharerUnfollowR POST diff --git a/src/Vervis/Handler/Person.hs b/src/Vervis/Handler/Person.hs index 99ff89b..2aefb56 100644 --- a/src/Vervis/Handler/Person.hs +++ b/src/Vervis/Handler/Person.hs @@ -143,6 +143,7 @@ getPerson shr sharer (Entity pid person) = do , actorInbox = encodeRouteLocal $ SharerInboxR shr , actorOutbox = Just $ encodeRouteLocal $ SharerOutboxR shr , actorFollowers = Just $ encodeRouteLocal $ SharerFollowersR shr + , actorFollowing = Just $ encodeRouteLocal $ SharerFollowingR shr , actorPublicKeys = [ Left $ encodeRouteLocal ActorKey1R , Left $ encodeRouteLocal ActorKey2R diff --git a/src/Vervis/Handler/Project.hs b/src/Vervis/Handler/Project.hs index 661250e..5e3454f 100644 --- a/src/Vervis/Handler/Project.hs +++ b/src/Vervis/Handler/Project.hs @@ -153,6 +153,7 @@ getProjectR shar proj = do Just $ route2local $ ProjectOutboxR shar proj , actorFollowers = Just $ route2local $ ProjectFollowersR shar proj + , actorFollowing = Nothing , actorPublicKeys = [ Left $ route2local ActorKey1R , Left $ route2local ActorKey2R diff --git a/src/Vervis/Handler/Repo.hs b/src/Vervis/Handler/Repo.hs index 0617afe..3a3edd1 100644 --- a/src/Vervis/Handler/Repo.hs +++ b/src/Vervis/Handler/Repo.hs @@ -227,6 +227,7 @@ getRepoR shr rp = do Just $ encodeRouteLocal $ RepoOutboxR shr rp , actorFollowers = Just $ encodeRouteLocal $ RepoFollowersR shr rp + , actorFollowing = Nothing , actorPublicKeys = [ Left $ encodeRouteLocal ActorKey1R , Left $ encodeRouteLocal ActorKey2R diff --git a/src/Vervis/Handler/Sharer.hs b/src/Vervis/Handler/Sharer.hs index 6a84fd3..b74b016 100644 --- a/src/Vervis/Handler/Sharer.hs +++ b/src/Vervis/Handler/Sharer.hs @@ -17,10 +17,14 @@ module Vervis.Handler.Sharer ( getSharersR , getSharerR , getSharerFollowersR + , getSharerFollowingR ) where import Control.Applicative ((<|>)) +import Control.Exception (throwIO) +import Control.Monad +import Control.Monad.IO.Class import Control.Monad.Logger (logWarn) import Control.Monad.Trans.Maybe import Data.Monoid ((<>)) @@ -31,6 +35,12 @@ import Yesod.Core.Content (TypedContent) import Yesod.Core.Handler (redirect, notFound) import Yesod.Persist.Core (runDB, getBy404) +import qualified Database.Esqueleto as E + +import Web.ActivityPub +import Yesod.ActivityPub +import Yesod.FedURI + import Database.Persist.Local import Yesod.Persist.Local @@ -87,3 +97,70 @@ getSharerFollowersR shr = getFollowersCollection here getFsid case val of Left person -> return $ personFollowers person Right _group -> notFound + +getSharerFollowingR :: ShrIdent -> Handler TypedContent +getSharerFollowingR shr = do + (localTotal, sharers, projects, tickets, repos, remotes) <- runDB $ do + sid <- getKeyBy404 $ UniqueSharer shr + pid <- getKeyBy404 $ UniquePersonIdent sid + fsids <- + map (followTarget . entityVal) <$> + selectList [FollowPerson ==. pid] [] + (,,,,,) (length fsids) + <$> getSharers fsids + <*> getProjects fsids + <*> getTickets fsids + <*> getRepos fsids + <*> getRemotes pid + let locals = sharers ++ projects ++ tickets ++ repos + unless (length locals == localTotal) $ + liftIO $ throwIO $ userError "Bug! List length mismatch" + + encodeRouteLocal <- getEncodeRouteLocal + encodeRouteHome <- getEncodeRouteHome + let here = SharerFollowingR shr + followingAP = Collection + { collectionId = encodeRouteLocal here + , collectionType = CollectionTypeUnordered + , collectionTotalItems = Just $ localTotal + length remotes + , collectionCurrent = Nothing + , collectionFirst = Nothing + , collectionLast = Nothing + , collectionItems = map encodeRouteHome locals ++ remotes + } + provideHtmlAndAP followingAP $ redirectToPrettyJSON here + where + getSharers fsids = do + sids <- + map (personIdent . entityVal) <$> + selectList [PersonFollowers <-. fsids] [] + map (SharerR . sharerIdent . entityVal) <$> + selectList [SharerId <-. sids] [] + getProjects fsids = do + jids <- selectKeysList [ProjectFollowers <-. fsids] [] + pairs <- E.select $ E.from $ \ (j `E.InnerJoin` s) -> do + E.on $ j E.^. ProjectSharer E.==. s E.^. SharerId + E.where_ $ j E.^. ProjectId `E.in_` E.valList jids + return (s E.^. SharerIdent, j E.^. ProjectIdent) + return $ map (\ (E.Value shr, E.Value prj) -> ProjectR shr prj) pairs + getTickets fsids = do + tids <- selectKeysList [TicketFollowers <-. fsids] [] + triples <- E.select $ E.from $ \ (t `E.InnerJoin` j `E.InnerJoin` s) -> do + E.on $ j E.^. ProjectSharer E.==. s E.^. SharerId + E.on $ t E.^. TicketProject E.==. j E.^. ProjectId + E.where_ $ t E.^. TicketId `E.in_` E.valList tids + return + (s E.^. SharerIdent, j E.^. ProjectIdent, t E.^. TicketNumber) + return $ + map (\ (E.Value shr, E.Value prj, E.Value num) -> TicketR shr prj num) + triples + getRepos fsids = do + rids <- selectKeysList [RepoFollowers <-. fsids] [] + pairs <- E.select $ E.from $ \ (r `E.InnerJoin` s) -> do + E.on $ r E.^. RepoSharer E.==. s E.^. SharerId + E.where_ $ r E.^. RepoId `E.in_` E.valList rids + return (s E.^. SharerIdent, r E.^. RepoIdent) + return $ map (\ (E.Value shr, E.Value rp) -> RepoR shr rp) pairs + getRemotes pid = + map (followRemoteTarget . entityVal) <$> + selectList [FollowRemotePerson ==. pid] [] diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index c531d77..357bcb1 100644 --- a/src/Web/ActivityPub.hs +++ b/src/Web/ActivityPub.hs @@ -350,6 +350,7 @@ data Actor u = Actor , actorInbox :: LocalURI , actorOutbox :: Maybe LocalURI , actorFollowers :: Maybe LocalURI + , actorFollowing :: Maybe LocalURI , actorPublicKeys :: [Either LocalURI (PublicKey u)] , actorSshKeys :: [LocalURI] } @@ -367,10 +368,11 @@ instance ActivityPub Actor where <*> withAuthorityO authority (o .: "inbox") <*> withAuthorityMaybeO authority (o .:? "outbox") <*> withAuthorityMaybeO authority (o .:? "followers") + <*> withAuthorityMaybeO authority (o .:? "following") <*> withAuthorityT authority (parsePublicKeySet =<< o .: "publicKey") <*> (traverse (withAuthorityO authority . return) =<< o .: "sshKey") toSeries authority - (Actor id_ typ musername mname msummary inbox outbox followers pkeys skeys) + (Actor id_ typ musername mname msummary inbox outbox followers following pkeys skeys) = "id" .= ObjURI authority id_ <> "type" .= typ <> "preferredUsername" .=? musername @@ -379,6 +381,7 @@ instance ActivityPub Actor where <> "inbox" .= ObjURI authority inbox <> "outbox" .=? (ObjURI authority <$> outbox) <> "followers" .=? (ObjURI authority <$> followers) + <> "following" .=? (ObjURI authority <$> following) <> "publicKey" `pair` encodePublicKeySet authority pkeys <> "sshKey" .=% map (ObjURI authority) skeys diff --git a/templates/default-layout.hamlet b/templates/default-layout.hamlet index 670c89f..5de5edc 100644 --- a/templates/default-layout.hamlet +++ b/templates/default-layout.hamlet @@ -27,6 +27,9 @@ $maybe (Entity _pid person, verified, sharer, unread) <- mperson [🐤 Followers] + + + [🐔 Following] [📣 Publish an activity]