When HTTP-fetching actors, remember their 'followers' as a LocalURI

The implementation felt quite weird, had to add an extra field to Fetched and
to VerifKeyDetail. Should probably figure out the whole mess in that code, have
something clean there. Easily add fields. Easily and safely re-fetch an actor
or key.

config/models

@@ -146,6 +146,7 @@ RemoteActor
     ident      RemoteObjectId
     name       Text Maybe
     inbox      LocalURI
+    followers  LocalURI       Maybe
     errorSince UTCTime        Maybe
 
     UniqueRemoteActor ident

src/Vervis/Federation/Auth.hs

@@ -152,7 +152,7 @@ verifyActorSig' malgo input (Signature signature) host luKey mluActorHeader = do
                 return (vk, mremote)
         case ments of
             Just (Entity vkid vk, mremote) -> do
-                (ua, s, rsid) <-
+                (ua, s, rsid, ra) <-
                     case mremote of
                         Just (ro, rsid, rs) -> do
                             let sharer = remoteObjectIdent ro
@@ -160,14 +160,15 @@ verifyActorSig' malgo input (Signature signature) host luKey mluActorHeader = do
                                 if sharer == lu
                                     then return ()
                                     else throwE "Key's owner doesn't match actor header"
-                            return (sharer, False, rsid)
+                            return (sharer, False, rsid, rs)
                         Nothing -> do
                             ua <- case mluActorHeader of
                                 Nothing -> throwE "Got a sig with an instance key, but actor header not specified!"
                                 Just u -> return u
                             let iid = verifKeyInstance vk
                             rsid <- withHostLock' host $ keyListedByActorShared iid vkid host luKey ua
-                            return (ua, True, rsid)
+                            ra <- lift $ runDB $ getJust rsid
+                            return (ua, True, rsid, ra)
                 return
                     ( Right (verifKeyInstance vk, vkid, rsid)
                     , VerifKeyDetail
@@ -175,6 +176,7 @@ verifyActorSig' malgo input (Signature signature) host luKey mluActorHeader = do
                         , vkdKey            = verifKeyPublic vk
                         , vkdExpires        = verifKeyExpires vk
                         , vkdActorId        = ua
+                        , vkdActorFollowers = remoteActorFollowers ra
                         , vkdShared         = s
                         }
                     )
@@ -226,13 +228,14 @@ verifyActorSig' malgo input (Signature signature) host luKey mluActorHeader = do
         -- , actdDigest    = digest
         }
     where
-    fetched2vkd uk (Fetched k mexp ua mname uinb s) =
+    fetched2vkd uk (Fetched k mexp ua mname uinb mufol s) =
         ( Left (mname, uinb)
         , VerifKeyDetail
             { vkdKeyId          = uk
             , vkdKey            = k
             , vkdExpires        = mexp
             , vkdActorId        = ua
+            , vkdActorFollowers = mufol
             , vkdShared         = s
             }
         )

src/Vervis/Federation/Ticket.hs

@@ -611,9 +611,9 @@ projectCreateTicketF now shrRecip prjRecip author body ticket muTarget = do
             , outboxItemPublished = now
             }
         obikhidAccept <- encodeKeyHashid obiidAccept
+        ra <- getJust $ remoteAuthorId author
         summary <- do
             let uAuthor@(ObjURI hAuthor luAuthor) = remoteAuthorURI author
-            ra <- getJust $ remoteAuthorId author
             TextHtml . TL.toStrict . renderHtml <$>
                 withUrlRenderer
                     [hamlet|
@@ -639,10 +639,10 @@ projectCreateTicketF now shrRecip prjRecip author body ticket muTarget = do
                 ]
             remoteRecipsA =
                 objUriLocal (remoteAuthorURI author) :| []
-            remoteRecipsC =
+            remoteRecipsC = catMaybes
-                [ LocalURI $ localUriPath (objUriLocal $ remoteAuthorURI author) <> "/followers"
+                [ remoteActorFollowers ra
-                , AP.ticketParticipants tlocal
+                , Just $ AP.ticketParticipants tlocal
-                , AP.ticketTeam tlocal
+                , Just $ AP.ticketTeam tlocal
                 ]
             localRecips =
                 map encodeRouteHome $

src/Vervis/Migration.hs

@@ -1513,6 +1513,11 @@ changes hLocal ctx =
     , addEntities model_2020_04_07
       -- 236
     , addEntities model_2020_04_09
+      -- 237
+    , addFieldPrimOptional
+        "RemoteActor"
+        (Nothing :: Maybe Text)
+        "followers"
     ]
 
 migrateDB

src/Vervis/RemoteActorStore.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2019 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2019, 2020 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -135,12 +135,14 @@ instanceAndActor
     -> LocalURI
     -> Maybe Text
     -> LocalURI
+    -> Maybe LocalURI
     -> YesodDB site (InstanceId, RemoteActorId, Maybe Bool)
-instanceAndActor host luActor mname luInbox = do
+instanceAndActor host luActor mname luInbox mluFollowers = do
     (iid, inew) <- idAndNew <$> insertBy' (Instance host)
     (raid, ranew) <- do
         roid <- either entityKey id <$> insertBy' (RemoteObject iid luActor)
-        idAndNew <$> insertBy' (RemoteActor roid mname luInbox Nothing)
+        idAndNew <$>
+            insertBy' (RemoteActor roid mname luInbox mluFollowers Nothing)
     return $
         ( iid
         , raid
@@ -340,7 +342,7 @@ keyListedByActorShared iid vkid host luKey luActor = do
             actor <- ExceptT (keyListedByActor manager host luKey luActor)
             lift $ runDB $ do
                 roid <- either entityKey id <$> insertBy' (RemoteObject iid luActor)
-                either entityKey id <$> insertBy' (RemoteActor roid (actorName actor <|> actorUsername actor) (actorInbox actor) Nothing)
+                either entityKey id <$> insertBy' (RemoteActor roid (actorName actor <|> actorUsername actor) (actorInbox actor) (actorFollowers actor) Nothing)
         RoomModeCached m -> do
             eresult <- do
                 ments <- lift $ runDB $ do
@@ -367,7 +369,7 @@ keyListedByActorShared iid vkid host luKey luActor = do
                             Nothing -> do
                                 rsid <- do
                                     roid <- either entityKey id <$> insertBy' (RemoteObject iid luActor)
-                                    either entityKey id <$> insertBy' (RemoteActor roid (actorName actor <|> actorUsername actor) (actorInbox actor) Nothing)
+                                    either entityKey id <$> insertBy' (RemoteActor roid (actorName actor <|> actorUsername actor) (actorInbox actor) (actorFollowers actor) Nothing)
                                 when vkExists $ insert_ $ VerifKeySharedUsage vkid rsid
                                 return $ Right rsid
                             Just rsid -> runExceptT $ do
@@ -388,6 +390,7 @@ data VerifKeyDetail = VerifKeyDetail
     , vkdKey            :: PublicVerifKey
     , vkdExpires        :: Maybe UTCTime
     , vkdActorId        :: LocalURI
+    , vkdActorFollowers :: Maybe LocalURI
     , vkdShared         :: Bool
     }
 
@@ -407,11 +410,11 @@ addVerifKey h mname uinb vkd =
         then addSharedKey h uinb vkd
         else addPersonalKey h uinb vkd
     where
-    addSharedKey host luInbox (VerifKeyDetail luKey key mexpires luActor _) = do
+    addSharedKey host luInbox (VerifKeyDetail luKey key mexpires luActor mluFollowers _) = do
         reject <- getsYesod siteRejectOnMaxKeys
         roomModeA <- getsYesod $ roomModeFromLimit . siteActorRoomMode
         roomModeI <- getsYesod $ roomModeFromLimit . siteInstanceRoomMode
-        (iid, rsid, inew) <- lift $ instanceAndActor host luActor mname luInbox
+        (iid, rsid, inew) <- lift $ instanceAndActor host luActor mname luInbox mluFollowers
         case roomModeI of
             RoomModeInstant ->
                 when reject $ throwE "Instance key storage limit is 0 and set to reject"
@@ -442,10 +445,10 @@ addVerifKey h mname uinb vkd =
         where
         instanceRoom n iid =
             (< n) <$> count [VerifKeyInstance ==. iid, VerifKeySharer ==. Nothing]
-    addPersonalKey host luInbox (VerifKeyDetail luKey key mexpires luActor _) = do
+    addPersonalKey host luInbox (VerifKeyDetail luKey key mexpires luActor mluFollowers _) = do
         reject <- getsYesod siteRejectOnMaxKeys
         roomMode <- getsYesod $ roomModeFromLimit . siteActorRoomMode
-        (iid, rsid, inew) <- lift $ instanceAndActor host luActor mname luInbox
+        (iid, rsid, inew) <- lift $ instanceAndActor host luActor mname luInbox mluFollowers
         case roomMode of
             RoomModeInstant ->
                 when reject $ throwE "Actor key storage limit is 0 and set to reject"
@@ -498,6 +501,7 @@ actorFetchShareAction u (site, iid) = flip runWorkerT site $ do
                                 , remoteActorName       =
                                     actorName actor <|> actorUsername actor
                                 , remoteActorInbox      = actorInbox actor
+                                , remoteActorFollowers  = actorFollowers actor
                                 , remoteActorErrorSince = Nothing
                                 }
                         Just . either id (flip Entity ra) <$> insertBy' ra

src/Web/ActivityPub.hs

@@ -1431,6 +1431,9 @@ data Fetched = Fetched
       -- ^ Name of the actor for whom the key's signature applies.
     , fetchedActorInbox     :: LocalURI
       -- ^ The inbox URI of the actor for whom the key's signature applies.
+    , fetchedActorFollowers :: Maybe LocalURI
+      -- ^ The follower collection URI of the actor for whom the key's
+      -- signature applies.
     , fetchedKeyShared      :: Bool
       -- ^ Whether the key we received is shared. A shared key can sign
       --   requests for any actor on the same instance, while a personal key is
@@ -1613,6 +1616,7 @@ fetchUnknownKey manager malgo host mluActor luKey = do
                     , fetchedActorId        = luActor
                     , fetchedActorName      = actorName actor <|> actorUsername actor
                     , fetchedActorInbox     = actorInbox actor
+                    , fetchedActorFollowers = actorFollowers actor
                     , fetchedKeyShared      = oi
                     }
             Right actor -> do
@@ -1637,6 +1641,7 @@ fetchUnknownKey manager malgo host mluActor luKey = do
                     , fetchedActorId        = owner
                     , fetchedActorName      = actorName actor <|> actorUsername actor
                     , fetchedActorInbox     = actorInbox actor
+                    , fetchedActorFollowers = actorFollowers actor
                     , fetchedKeyShared      = False
                     }
     ExceptT . pure $ verifyAlgo malgo $ fetchedPublicKey fetched