DB: Store the 'type' of remote actors

src/Vervis/Actor2.hs

@@ -416,6 +416,7 @@ fetchRemoteResource instanceID host localURI = do
                                     , remoteActorInbox      = AP.actorInbox local
                                     , remoteActorFollowers  = AP.actorFollowers local
                                     , remoteActorErrorSince = Nothing
+                                    , remoteActorType       = AP.actorType detail
                                     }
                             Right . Left . either id id <$> insertByEntity' ra
                         AP.ResourceChild luId luManager -> do

src/Vervis/Federation/Auth.hs

@@ -206,6 +206,7 @@ verifyActorSig' malgo input (Signature signature) host luKey mluActorHeader = do
                         , vkdExpires        = verifKeyExpires vk
                         , vkdActorId        = ua
                         , vkdActorFollowers = remoteActorFollowers ra
+                        , vkdActorType      = remoteActorType ra
                         , vkdShared         = s
                         }
                     )
@@ -257,7 +258,7 @@ verifyActorSig' malgo input (Signature signature) host luKey mluActorHeader = do
         -- , actdDigest    = digest
         }
     where
-    fetched2vkd uk (Fetched k mexp ua mname uinb mufol s) =
+    fetched2vkd uk (Fetched k mexp ua mname uinb mufol ad s) =
         ( Left (mname, uinb)
         , VerifKeyDetail
             { vkdKeyId          = uk
@@ -265,6 +266,7 @@ verifyActorSig' malgo input (Signature signature) host luKey mluActorHeader = do
             , vkdExpires        = mexp
             , vkdActorId        = ua
             , vkdActorFollowers = mufol
+            , vkdActorType      = AP.actorType ad
             , vkdShared         = s
             }
         )

src/Vervis/Fetch.hs

@@ -132,6 +132,7 @@ insertRemoteActor h lu (AP.Actor local detail) = do
             , remoteActorInbox      = AP.actorInbox local
             , remoteActorFollowers  = AP.actorFollowers local
             , remoteActorErrorSince = Nothing
+            , remoteActorType       = AP.actorType detail
             }
     either entityKey id <$> insertBy' ra
 

src/Vervis/Migration.hs

@@ -2960,6 +2960,8 @@ changes hLocal ctx =
     , addEntities model_541_project
       -- 542
     , addEntities model_542_component
+      -- 543
+    , addFieldPrimRequired "RemoteActor" ("" :: Text) "type"
     ]
 
 migrateDB

src/Vervis/Model.hs

@@ -25,7 +25,7 @@ import Data.Hashable
 import Data.Text (Text)
 import Data.Time.Clock
 import Database.Persist.Quasi
-import Database.Persist.Sql (fromSqlKey)
+import Database.Persist.Sql
 import Text.Email.Validate (EmailAddress)
 
 import Database.Persist.Schema.TH hiding (modelFile)
@@ -39,10 +39,11 @@ import Database.Persist.JSON
 import Development.PatchMediaType
 import Development.PatchMediaType.Persist
 import Network.FedURI
-import Web.ActivityPub (Doc, Activity, Role)
+import Web.ActivityPub (Doc, Activity, Role, ActorType)
 import Web.Text (HTML, PandocMarkdown)
 
 import Vervis.FedURI
+import Vervis.Model.Entity
 import Vervis.Model.Group
 import Vervis.Model.Ident
 import Vervis.Model.Role

src/Vervis/Model/Entity.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2016, 2023 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -21,9 +21,19 @@ module Vervis.Model.Entity
 where
 
 import Data.Text (Text)
-import Database.Persist.Class (PersistEntity)
+import Database.Persist.Types
+import Database.Persist.Sql
+import Web.ActivityPub (ActorType, parseActorType, renderActorType)
 
 class PersistEntity r => VervisEntity r where
     type VervisEntityIdent r
     vervisEntityIdent :: r -> VervisEntityIdent r
     vervisEntityName  :: r -> Maybe Text
+
+instance PersistField ActorType where
+    toPersistValue = toPersistValue . renderActorType
+    fromPersistValue = fmap parseActorType . fromPersistValue
+
+instance PersistFieldSql ActorType where
+    sqlType = sqlType . fmap renderActorType
+

src/Vervis/RemoteActorStore.hs

@@ -67,6 +67,8 @@ import Network.FedURI
 import Web.ActivityPub
 import Yesod.MonadSite
 
+import qualified Web.ActivityPub as AP
+
 import Vervis.Actor
 import Vervis.FedURI
 import Vervis.Model hiding (Actor (..))
@@ -139,13 +141,14 @@ instanceAndActor
     -> Maybe Text
     -> LocalURI
     -> Maybe LocalURI
+    -> AP.ActorType
     -> YesodDB site (InstanceId, RemoteActorId, Maybe Bool)
-instanceAndActor host luActor mname luInbox mluFollowers = do
+instanceAndActor host luActor mname luInbox mluFollowers typ = do
     (iid, inew) <- idAndNew <$> insertBy' (Instance host)
     (raid, ranew) <- do
         roid <- either entityKey id <$> insertBy' (RemoteObject iid luActor)
         idAndNew <$>
-            insertBy' (RemoteActor roid mname luInbox mluFollowers Nothing)
+            insertBy' (RemoteActor roid mname luInbox mluFollowers Nothing typ)
     return $
         ( iid
         , raid
@@ -345,7 +348,7 @@ keyListedByActorShared iid vkid host luKey luActor = do
             Actor local detail <- ExceptT (keyListedByActor manager host luKey luActor)
             lift $ runDB $ do
                 roid <- either entityKey id <$> insertBy' (RemoteObject iid luActor)
-                either entityKey id <$> insertBy' (RemoteActor roid (actorName detail <|> actorUsername detail) (actorInbox local) (actorFollowers local) Nothing)
+                either entityKey id <$> insertBy' (RemoteActor roid (actorName detail <|> actorUsername detail) (actorInbox local) (actorFollowers local) Nothing (AP.actorType detail))
         RoomModeCached m -> do
             eresult <- do
                 ments <- lift $ runDB $ do
@@ -372,7 +375,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 detail <|> actorUsername detail) (actorInbox local) (actorFollowers local) Nothing)
+                                    either entityKey id <$> insertBy' (RemoteActor roid (actorName detail <|> actorUsername detail) (actorInbox local) (actorFollowers local) Nothing (AP.actorType detail))
                                 when vkExists $ insert_ $ VerifKeySharedUsage vkid rsid
                                 return $ Right rsid
                             Just rsid -> runExceptT $ do
@@ -394,6 +397,7 @@ data VerifKeyDetail = VerifKeyDetail
     , vkdExpires        :: Maybe UTCTime
     , vkdActorId        :: LocalURI
     , vkdActorFollowers :: Maybe LocalURI
+    , vkdActorType      :: AP.ActorType
     , vkdShared         :: Bool
     }
 
@@ -413,11 +417,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 mluFollowers _) = do
+    addSharedKey host luInbox (VerifKeyDetail luKey key mexpires luActor mluFollowers atyp _) = do
         reject <- getsYesod siteRejectOnMaxKeys
         roomModeA <- getsYesod $ roomModeFromLimit . siteActorRoomMode
         roomModeI <- getsYesod $ roomModeFromLimit . siteInstanceRoomMode
-        (iid, rsid, inew) <- lift $ instanceAndActor host luActor mname luInbox mluFollowers
+        (iid, rsid, inew) <- lift $ instanceAndActor host luActor mname luInbox mluFollowers atyp
         case roomModeI of
             RoomModeInstant ->
                 when reject $ throwE "Instance key storage limit is 0 and set to reject"
@@ -448,10 +452,10 @@ addVerifKey h mname uinb vkd =
         where
         instanceRoom n iid =
             (< n) <$> count [VerifKeyInstance ==. iid, VerifKeySharer ==. Nothing]
-    addPersonalKey host luInbox (VerifKeyDetail luKey key mexpires luActor mluFollowers _) = do
+    addPersonalKey host luInbox (VerifKeyDetail luKey key mexpires luActor mluFollowers atyp _) = do
         reject <- getsYesod siteRejectOnMaxKeys
         roomMode <- getsYesod $ roomModeFromLimit . siteActorRoomMode
-        (iid, rsid, inew) <- lift $ instanceAndActor host luActor mname luInbox mluFollowers
+        (iid, rsid, inew) <- lift $ instanceAndActor host luActor mname luInbox mluFollowers atyp
         case roomMode of
             RoomModeInstant ->
                 when reject $ throwE "Actor key storage limit is 0 and set to reject"
@@ -495,6 +499,7 @@ actorFetchShareAction u@(ObjURI h lu) (pool, manager, iid) = do
                                 , remoteActorInbox      = actorInbox local
                                 , remoteActorFollowers  = actorFollowers local
                                 , remoteActorErrorSince = Nothing
+                                , remoteActorType       = AP.actorType detail
                                 }
                         Just . either id (flip Entity ra) <$> insertBy' ra
                     RecipientCollection _ -> rundb $ do

src/Web/ActivityPub.hs

@@ -30,6 +30,8 @@ module Web.ActivityPub
       -- ActivityPub actor document including a public key, with a 'FromJSON'
       -- instance for fetching and a 'ToJSON' instance for publishing.
     , ActorType (..)
+    , parseActorType
+    , renderActorType
     --, Algorithm (..)
     , Owner (..)
     , PublicKey (..)
@@ -379,10 +381,8 @@ data ActorType
     | ActorTypeOther Text
     deriving Eq
 
-instance FromJSON ActorType where
-    parseJSON = withText "ActorType" $ pure . parse
-        where
-        parse t
+parseActorType :: Text -> ActorType
+parseActorType t
     | t == "Person"        = ActorTypePerson
     | t == "Repository"    = ActorTypeRepo
     | t == "TicketTracker" = ActorTypeTicketTracker
@@ -390,10 +390,8 @@ instance FromJSON ActorType where
     | t == "Project"       = ActorTypeProject
     | otherwise            = ActorTypeOther t
 
-instance ToJSON ActorType where
-    toJSON = error "toJSON ActorType"
-    toEncoding at =
-        toEncoding $ case at of
+renderActorType :: ActorType -> Text
+renderActorType = \case
     ActorTypePerson        -> "Person"
     ActorTypeRepo          -> "Repository"
     ActorTypeTicketTracker -> "TicketTracker"
@@ -401,6 +399,13 @@ instance ToJSON ActorType where
     ActorTypeProject       -> "Project"
     ActorTypeOther t       -> t
 
+instance FromJSON ActorType where
+    parseJSON = withText "ActorType" $ pure . parseActorType
+
+instance ToJSON ActorType where
+    toJSON = error "toJSON ActorType"
+    toEncoding = toEncoding . renderActorType
+
 data Owner = OwnerInstance | OwnerActor LocalURI
 
 ownerShared :: Owner -> Bool
@@ -2518,6 +2523,7 @@ data Fetched = Fetched
     , fetchedActorFollowers :: Maybe LocalURI
       -- ^ The follower collection URI of the actor for whom the key's
       -- signature applies.
+    , fetchedActorDetail    :: ActorDetail
     , 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
@@ -2722,6 +2728,7 @@ fetchUnknownKey manager malgo host mluActor luKey = do
                     , fetchedActorName      = actorName detail <|> actorUsername detail
                     , fetchedActorInbox     = actorInbox local
                     , fetchedActorFollowers = actorFollowers local
+                    , fetchedActorDetail    = detail
                     , fetchedKeyShared      = oi
                     }
             Right (Actor local detail) -> do
@@ -2747,6 +2754,7 @@ fetchUnknownKey manager malgo host mluActor luKey = do
                     , fetchedActorName      = actorName detail <|> actorUsername detail
                     , fetchedActorInbox     = actorInbox local
                     , fetchedActorFollowers = actorFollowers local
+                    , fetchedActorDetail    = detail
                     , fetchedKeyShared      = False
                     }
     ExceptT . pure $ verifyAlgo malgo $ fetchedPublicKey fetched

th/models

@@ -52,6 +52,7 @@ RemoteActor
     inbox      LocalURI
     followers  LocalURI       Maybe
     errorSince UTCTime        Maybe
+    type       ActorType
 
     UniqueRemoteActor ident