Provide 'following' collections and link in page header

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
 

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

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

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

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] []

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
 

templates/default-layout.hamlet

@@ -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]