Provide 'following' collections and link in page header
This commit is contained in:
fr33domlover
parent
b914ef4d16
commit
bc379a864f
7 changed files with 88 additions and 1 deletions
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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] []
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -27,6 +27,9 @@ $maybe (Entity _pid person, verified, sharer, unread) <- mperson
|
|||
<span>
|
||||
<a href=@{SharerFollowersR $ sharerIdent sharer}>
|
||||
[🐤 Followers]
|
||||
<span>
|
||||
<a href=@{SharerFollowingR $ sharerIdent sharer}>
|
||||
[🐔 Following]
|
||||
<span>
|
||||
<a href=@{PublishR}>
|
||||
[📣 Publish an activity]
|
||||
|
|
|
|||
Loading…
Reference in a new issue