diff --git a/src/Vervis/Actor2.hs b/src/Vervis/Actor2.hs index f93cbe3..13a9d88 100644 --- a/src/Vervis/Actor2.hs +++ b/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 diff --git a/src/Vervis/Federation/Auth.hs b/src/Vervis/Federation/Auth.hs index be46837..7e54de8 100644 --- a/src/Vervis/Federation/Auth.hs +++ b/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 } ) diff --git a/src/Vervis/Fetch.hs b/src/Vervis/Fetch.hs index db555cd..fb673ff 100644 --- a/src/Vervis/Fetch.hs +++ b/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 diff --git a/src/Vervis/Migration.hs b/src/Vervis/Migration.hs index 4d6e11b..3585da6 100644 --- a/src/Vervis/Migration.hs +++ b/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 diff --git a/src/Vervis/Model.hs b/src/Vervis/Model.hs index 6a584f4..b4e7229 100644 --- a/src/Vervis/Model.hs +++ b/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 diff --git a/src/Vervis/Model/Entity.hs b/src/Vervis/Model/Entity.hs index 6c692e5..574fdfe 100644 --- a/src/Vervis/Model/Entity.hs +++ b/src/Vervis/Model/Entity.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2016 by fr33domlover . + - Written in 2016, 2023 by fr33domlover . - - ♡ 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 + diff --git a/src/Vervis/RemoteActorStore.hs b/src/Vervis/RemoteActorStore.hs index 495d6a5..c6cc79e 100644 --- a/src/Vervis/RemoteActorStore.hs +++ b/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 diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index 0b01b4d..1401046 100644 --- a/src/Web/ActivityPub.hs +++ b/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,27 +381,30 @@ data ActorType | ActorTypeOther Text deriving Eq +parseActorType :: Text -> ActorType +parseActorType t + | t == "Person" = ActorTypePerson + | t == "Repository" = ActorTypeRepo + | t == "TicketTracker" = ActorTypeTicketTracker + | t == "PatchTracker" = ActorTypePatchTracker + | t == "Project" = ActorTypeProject + | otherwise = ActorTypeOther t + +renderActorType :: ActorType -> Text +renderActorType = \case + ActorTypePerson -> "Person" + ActorTypeRepo -> "Repository" + ActorTypeTicketTracker -> "TicketTracker" + ActorTypePatchTracker -> "PatchTracker" + ActorTypeProject -> "Project" + ActorTypeOther t -> t + instance FromJSON ActorType where - parseJSON = withText "ActorType" $ pure . parse - where - parse t - | t == "Person" = ActorTypePerson - | t == "Repository" = ActorTypeRepo - | t == "TicketTracker" = ActorTypeTicketTracker - | t == "PatchTracker" = ActorTypePatchTracker - | t == "Project" = ActorTypeProject - | otherwise = ActorTypeOther t + parseJSON = withText "ActorType" $ pure . parseActorType instance ToJSON ActorType where toJSON = error "toJSON ActorType" - toEncoding at = - toEncoding $ case at of - ActorTypePerson -> "Person" - ActorTypeRepo -> "Repository" - ActorTypeTicketTracker -> "TicketTracker" - ActorTypePatchTracker -> "PatchTracker" - ActorTypeProject -> "Project" - ActorTypeOther t -> t + toEncoding = toEncoding . renderActorType data Owner = OwnerInstance | OwnerActor LocalURI @@ -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 diff --git a/th/models b/th/models index 7ec0149..e8dacc0 100644 --- a/th/models +++ b/th/models @@ -52,6 +52,7 @@ RemoteActor inbox LocalURI followers LocalURI Maybe errorSince UTCTime Maybe + type ActorType UniqueRemoteActor ident