From e2591734d3c69e1deda7beef017673eb5f3cb394 Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Sun, 24 Jul 2022 16:52:28 +0000 Subject: [PATCH] Web.ActivityPub: Update representation of actor and project Ugh, that module is such a horrible mess... I hope to turn it soon into something sane. Is there some generic non-clumsy way restructure the AP parser/encoder API? For now, making these ugly changes to support the represenation of Create {TicketTracker}, which I'm about to implement. --- src/Vervis/API.hs | 6 +- src/Vervis/ActivityPub.hs | 2 +- src/Vervis/Client.hs | 5 +- src/Vervis/Federation.hs | 12 +- src/Vervis/Federation/Discussion.hs | 2 +- src/Vervis/Federation/Offer.hs | 2 +- src/Vervis/Federation/Ticket.hs | 2 +- src/Vervis/Handler/Client.hs | 8 +- src/Vervis/Handler/Inbox.hs | 2 +- src/Vervis/Handler/Person.hs | 34 ++-- src/Vervis/Handler/Project.hs | 46 +++--- src/Vervis/Handler/Repo.hs | 36 +++-- src/Vervis/Migration.hs | 3 +- src/Vervis/RemoteActorStore.hs | 16 +- src/Web/ActivityPub.hs | 231 ++++++++++++++++++---------- 15 files changed, 241 insertions(+), 166 deletions(-) diff --git a/src/Vervis/API.hs b/src/Vervis/API.hs index a2dee7b..4ff5b3f 100644 --- a/src/Vervis/API.hs +++ b/src/Vervis/API.hs @@ -87,7 +87,7 @@ import Crypto.PublicVerifKey import Database.Persist.JSON import Network.FedURI import Network.HTTP.Digest -import Web.ActivityPub hiding (Patch, Ticket, Follow, Repo (..), Project (..), Actor (..)) +import Web.ActivityPub hiding (Patch, Ticket, Follow, Repo (..), ActorLocal (..)) import Yesod.ActivityPub import Yesod.Auth.Unverified import Yesod.FedURI @@ -1099,7 +1099,7 @@ createNoteC (Entity pidUser personUser) sharerUser summary audience note muTarge , activitySummary = summary , activityAudience = blinded , activitySpecific = CreateActivity Create - { createObject = CreateNote Note + { createObject = CreateNote hLocal Note { noteId = Just $ encodeRouteLocal $ MessageR shrUser lmkhid , noteAttrib = luAttrib , noteAudience = emptyAudience @@ -1680,7 +1680,7 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT , activitySummary = summary , activityAudience = blinded , activitySpecific = CreateActivity Create - { createObject = CreateTicket AP.Ticket + { createObject = CreateTicket hLocal AP.Ticket { AP.ticketLocal = Just (hLocal, tlocal) , AP.ticketAttributedTo = luAttrib , AP.ticketPublished = Just now diff --git a/src/Vervis/ActivityPub.hs b/src/Vervis/ActivityPub.hs index a891448..aba4289 100644 --- a/src/Vervis/ActivityPub.hs +++ b/src/Vervis/ActivityPub.hs @@ -110,7 +110,7 @@ import Yesod.HttpSignature import Database.Persist.JSON import Network.FedURI import Network.HTTP.Digest -import Web.ActivityPub hiding (Author (..), Ticket, Project (..), Repo, Actor (..)) +import Web.ActivityPub hiding (Author (..), Ticket, Project (..), Repo, ActorLocal (..)) import Yesod.ActivityPub import Yesod.MonadSite import Yesod.FedURI diff --git a/src/Vervis/Client.hs b/src/Vervis/Client.hs index bb8b62f..3fd852d 100644 --- a/src/Vervis/Client.hs +++ b/src/Vervis/Client.hs @@ -54,7 +54,7 @@ import qualified Data.Text.Lazy as TL import Development.PatchMediaType import Network.FedURI -import Web.ActivityPub hiding (Follow, Ticket, Project (..), Repo, Actor (..)) +import Web.ActivityPub hiding (Follow, Ticket, Project (..), Repo, ActorLocal (..)) import Yesod.ActivityPub import Yesod.FedURI import Yesod.Hashids @@ -305,6 +305,7 @@ createTicket shrAuthor (TextHtml title) (TextPandocMarkdown desc) target context } encodeRouteLocal <- getEncodeRouteLocal + hLocal <- asksSite siteInstanceHost descHtml <- ExceptT . pure $ renderPandocMarkdown desc let ticket = AP.Ticket { AP.ticketLocal = Nothing @@ -320,7 +321,7 @@ createTicket shrAuthor (TextHtml title) (TextPandocMarkdown desc) target context , AP.ticketAttachment = Nothing } create = Create - { createObject = CreateTicket ticket + { createObject = CreateTicket hLocal ticket , createTarget = Just target } diff --git a/src/Vervis/Federation.hs b/src/Vervis/Federation.hs index 5c7bd23..343537c 100644 --- a/src/Vervis/Federation.hs +++ b/src/Vervis/Federation.hs @@ -286,9 +286,9 @@ handleSharerInbox shrRecip now (ActivityAuthRemote author) body = do _ -> return ("Unsupported add object type for sharers", Nothing) CreateActivity (Create obj mtarget) -> case obj of - CreateNote note -> + CreateNote _ note -> (,Nothing) <$> sharerCreateNoteF now shrRecip author body mfwd luActivity note - CreateTicket ticket -> + CreateTicket _ ticket -> (,Nothing) <$> sharerCreateTicketF now shrRecip author body mfwd luActivity ticket mtarget _ -> return ("Unsupported create object type for sharers", Nothing) FollowActivity follow -> @@ -332,9 +332,9 @@ handleProjectInbox shrRecip prjRecip now auth body = do case activitySpecific $ actbActivity body of CreateActivity (Create obj mtarget) -> case obj of - CreateNote note -> + CreateNote _ note -> (,Nothing) <$> projectCreateNoteF now shrRecip prjRecip remoteAuthor body mfwd luActivity note - CreateTicket ticket -> + CreateTicket _ ticket -> (,Nothing) <$> projectCreateTicketF now shrRecip prjRecip remoteAuthor body mfwd luActivity ticket mtarget _ -> error "Unsupported create object type for projects" FollowActivity follow -> @@ -391,9 +391,9 @@ handleRepoInbox shrRecip rpRecip now auth body = do _ -> return ("Unsupported add object type for repos", Nothing) CreateActivity (Create obj mtarget) -> case obj of - CreateNote note -> + CreateNote _ note -> (,Nothing) <$> repoCreateNoteF now shrRecip rpRecip remoteAuthor body mfwd luActivity note - CreateTicket ticket -> + CreateTicket _ ticket -> (,Nothing) <$> repoCreateTicketF now shrRecip rpRecip remoteAuthor body mfwd luActivity ticket mtarget _ -> error "Unsupported create object type for repos" FollowActivity follow -> diff --git a/src/Vervis/Federation/Discussion.hs b/src/Vervis/Federation/Discussion.hs index 55c1af7..802fe1b 100644 --- a/src/Vervis/Federation/Discussion.hs +++ b/src/Vervis/Federation/Discussion.hs @@ -53,7 +53,7 @@ import Yesod.HttpSignature import Database.Persist.JSON import Network.FedURI import Network.HTTP.Digest -import Web.ActivityPub hiding (Project (..), Actor (..)) +import Web.ActivityPub hiding (ActorLocal (..)) import Yesod.ActivityPub import Yesod.FedURI import Yesod.Hashids diff --git a/src/Vervis/Federation/Offer.hs b/src/Vervis/Federation/Offer.hs index 2be3b3c..31733e4 100644 --- a/src/Vervis/Federation/Offer.hs +++ b/src/Vervis/Federation/Offer.hs @@ -63,7 +63,7 @@ import qualified Data.Text.Lazy as TL import Database.Persist.JSON import Network.FedURI -import Web.ActivityPub hiding (Ticket (..), Follow, Project (..), Actor (..)) +import Web.ActivityPub hiding (Ticket (..), Follow, Project (..), ActorLocal (..)) import Yesod.ActivityPub import Yesod.FedURI import Yesod.Hashids diff --git a/src/Vervis/Federation/Ticket.hs b/src/Vervis/Federation/Ticket.hs index d5de572..cdd6948 100644 --- a/src/Vervis/Federation/Ticket.hs +++ b/src/Vervis/Federation/Ticket.hs @@ -78,7 +78,7 @@ import qualified Data.Text.Lazy as TL import Database.Persist.JSON import Network.FedURI -import Web.ActivityPub hiding (Patch, Ticket (..), Repo (..), Project (..), Actor (..)) +import Web.ActivityPub hiding (Patch, Ticket (..), Repo (..), Project (..), ActorLocal (..)) import Yesod.ActivityPub import Yesod.FedURI import Yesod.Hashids diff --git a/src/Vervis/Handler/Client.hs b/src/Vervis/Handler/Client.hs index 765b5d7..4efca13 100644 --- a/src/Vervis/Handler/Client.hs +++ b/src/Vervis/Handler/Client.hs @@ -385,9 +385,9 @@ postSharerOutboxR shr = do applyC eperson sharer summary audience mcap apply CreateActivity (Create obj mtarget) -> case obj of - CreateNote note -> + CreateNote _ note -> createNoteC eperson sharer summary audience note mtarget - CreateTicket ticket -> + CreateTicket _ ticket -> createTicketC eperson sharer summary audience ticket mtarget _ -> throwE "Unsupported Create 'object' type" FollowActivity follow -> @@ -529,7 +529,7 @@ postPublishR = do ExceptT $ C.createTicket (sharerIdent sharer) title desc target context let ticket = case createObject create of - CreateTicket t -> t + CreateTicket _ t -> t _ -> error "Create object isn't a ticket" target = createTarget create createTicketC eperson sharer (Just summary) audience ticket target @@ -931,7 +931,7 @@ postProjectTicketsR shr prj = do ExceptT $ createTicket shrAuthor (TextHtml title) (TextPandocMarkdown desc) project project let ticket = case obj of - CreateTicket t -> t + CreateTicket _ t -> t _ -> error "Create object isn't a ticket" obiid <- createTicketC eperson sharer (Just summary) audience ticket mtarget ExceptT $ runDB $ do diff --git a/src/Vervis/Handler/Inbox.hs b/src/Vervis/Handler/Inbox.hs index 02d2cf3..99b7e2f 100644 --- a/src/Vervis/Handler/Inbox.hs +++ b/src/Vervis/Handler/Inbox.hs @@ -75,7 +75,7 @@ import qualified Database.Esqueleto as E import Database.Persist.JSON import Network.FedURI -import Web.ActivityPub hiding (Project (..), Actor (..)) +import Web.ActivityPub hiding (Project (..), ActorLocal (..)) import Yesod.ActivityPub import Yesod.Auth.Unverified import Yesod.FedURI diff --git a/src/Vervis/Handler/Person.hs b/src/Vervis/Handler/Person.hs index a0b7d03..52d520f 100644 --- a/src/Vervis/Handler/Person.hs +++ b/src/Vervis/Handler/Person.hs @@ -135,21 +135,25 @@ getPerson shr sharer (Entity pid person) = do encodeKeyHashid <- getEncodeKeyHashid skids <- runDB $ P.selectKeysList [SshKeyPerson P.==. pid] [P.Asc SshKeyId] let personAP = Actor - { actorId = encodeRouteLocal $ SharerR shr - , actorType = ActorTypePerson - , actorUsername = Just $ shr2text shr - , actorName = sharerName sharer - , actorSummary = Nothing - , 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 - ] - , actorSshKeys = - map (encodeRouteLocal . SshKeyR shr . encodeKeyHashid) skids + { actorLocal = ActorLocal + { actorId = encodeRouteLocal $ SharerR shr + , 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 + ] + , actorSshKeys = + map (encodeRouteLocal . SshKeyR shr . encodeKeyHashid) skids + } + , actorDetail = ActorDetail + { actorType = ActorTypePerson + , actorUsername = Just $ shr2text shr + , actorName = sharerName sharer + , actorSummary = Nothing + } } secure <- getSecure provideHtmlAndAP personAP $(widgetFile "person") diff --git a/src/Vervis/Handler/Project.hs b/src/Vervis/Handler/Project.hs index a0c244b..c1b3eb5 100644 --- a/src/Vervis/Handler/Project.hs +++ b/src/Vervis/Handler/Project.hs @@ -51,7 +51,7 @@ import qualified Database.Esqueleto as E import Database.Persist.JSON import Network.FedURI -import Web.ActivityPub hiding (Project (..), Repo (..), Actor (..)) +import Web.ActivityPub hiding (Project (..), Repo (..), Actor (..), ActorDetail (..), ActorLocal (..)) import Yesod.ActivityPub import Yesod.FedURI import Yesod.MonadSite @@ -161,27 +161,31 @@ getProjectR shar proj = do route2fed <- getEncodeRouteHome route2local <- getEncodeRouteLocal - let projectAP = AP.Project - { AP.projectActor = AP.Actor - { AP.actorId = route2local $ ProjectR shar proj - , AP.actorType = ActorTypeProject - , AP.actorUsername = Nothing - , AP.actorName = - Just $ fromMaybe (prj2text proj) $ projectName project - , AP.actorSummary = projectDesc project - , AP.actorInbox = route2local $ ProjectInboxR shar proj - , AP.actorOutbox = - Just $ route2local $ ProjectOutboxR shar proj - , AP.actorFollowers = - Just $ route2local $ ProjectFollowersR shar proj - , AP.actorFollowing = Nothing - , AP.actorPublicKeys = - [ Left $ route2local ActorKey1R - , Left $ route2local ActorKey2R - ] - , AP.actorSshKeys = [] + let projectAP = AP.TicketTracker + { AP.ticketTrackerActor = AP.Actor + { AP.actorLocal = AP.ActorLocal + { AP.actorId = route2local $ ProjectR shar proj + , AP.actorInbox = route2local $ ProjectInboxR shar proj + , AP.actorOutbox = + Just $ route2local $ ProjectOutboxR shar proj + , AP.actorFollowers = + Just $ route2local $ ProjectFollowersR shar proj + , AP.actorFollowing = Nothing + , AP.actorPublicKeys = + [ Left $ route2local ActorKey1R + , Left $ route2local ActorKey2R + ] + , AP.actorSshKeys = [] + } + , AP.actorDetail = AP.ActorDetail + { AP.actorType = ActorTypeTicketTracker + , AP.actorUsername = Nothing + , AP.actorName = + Just $ fromMaybe (prj2text proj) $ projectName project + , AP.actorSummary = projectDesc project + } } - , AP.projectTeam = route2local $ ProjectTeamR shar proj + , AP.ticketTrackerTeam = route2local $ ProjectTeamR shar proj } followButton = followW diff --git a/src/Vervis/Handler/Repo.hs b/src/Vervis/Handler/Repo.hs index 390e838..7220563 100644 --- a/src/Vervis/Handler/Repo.hs +++ b/src/Vervis/Handler/Repo.hs @@ -239,22 +239,26 @@ getRepoR shr rp = do encodeRouteHome <- getEncodeRouteHome let repoAP = AP.Repo { AP.repoActor = Actor - { actorId = encodeRouteLocal $ RepoR shr rp - , actorType = ActorTypeRepo - , actorUsername = Nothing - , actorName = Just $ rp2text rp - , actorSummary = repoDesc repo - , actorInbox = encodeRouteLocal $ RepoInboxR shr rp - , actorOutbox = - Just $ encodeRouteLocal $ RepoOutboxR shr rp - , actorFollowers = - Just $ encodeRouteLocal $ RepoFollowersR shr rp - , actorFollowing = Nothing - , actorPublicKeys = - [ Left $ encodeRouteLocal ActorKey1R - , Left $ encodeRouteLocal ActorKey2R - ] - , actorSshKeys = [] + { actorLocal = ActorLocal + { actorId = encodeRouteLocal $ RepoR shr rp + , actorInbox = encodeRouteLocal $ RepoInboxR shr rp + , actorOutbox = + Just $ encodeRouteLocal $ RepoOutboxR shr rp + , actorFollowers = + Just $ encodeRouteLocal $ RepoFollowersR shr rp + , actorFollowing = Nothing + , actorPublicKeys = + [ Left $ encodeRouteLocal ActorKey1R + , Left $ encodeRouteLocal ActorKey2R + ] + , actorSshKeys = [] + } + , actorDetail = ActorDetail + { actorType = ActorTypeRepo + , actorUsername = Nothing + , actorName = Just $ rp2text rp + , actorSummary = repoDesc repo + } } , AP.repoTeam = encodeRouteLocal $ RepoTeamR shr rp , AP.repoVcs = repoVcs repo diff --git a/src/Vervis/Migration.hs b/src/Vervis/Migration.hs index 2778e9a..847c184 100644 --- a/src/Vervis/Migration.hs +++ b/src/Vervis/Migration.hs @@ -470,7 +470,7 @@ changes hLocal ctx = , activitySummary = Nothing , activityAudience = aud , activitySpecific = CreateActivity Create - { createObject = CreateNote Note + { createObject = CreateNote hLocal Note { noteId = Just luNote , noteAttrib = luAttrib , noteAudience = aud @@ -771,6 +771,7 @@ changes hLocal ctx = , ticketAssignedTo = Nothing , ticketResolved = Nothing , ticketAttachment = Nothing + , ticketContext = Nothing } summary = [hamlet| diff --git a/src/Vervis/RemoteActorStore.hs b/src/Vervis/RemoteActorStore.hs index 6114d6d..a47157b 100644 --- a/src/Vervis/RemoteActorStore.hs +++ b/src/Vervis/RemoteActorStore.hs @@ -339,10 +339,10 @@ keyListedByActorShared iid vkid host luKey luActor = do case roomMode of RoomModeInstant -> do when reject $ throwE "Actor key storage limit is 0 and set to reject" - actor <- ExceptT (keyListedByActor manager host luKey luActor) + 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 actor <|> actorUsername actor) (actorInbox actor) (actorFollowers actor) Nothing) + either entityKey id <$> insertBy' (RemoteActor roid (actorName detail <|> actorUsername detail) (actorInbox local) (actorFollowers local) Nothing) RoomModeCached m -> do eresult <- do ments <- lift $ runDB $ do @@ -362,14 +362,14 @@ keyListedByActorShared iid vkid host luKey luActor = do case eresult of Left rsid -> return rsid Right mrsid -> do - actor <- ExceptT (keyListedByActor manager host luKey luActor) + Actor local detail <- ExceptT (keyListedByActor manager host luKey luActor) ExceptT $ runDB $ do vkExists <- isJust <$> get vkid case mrsid of Nothing -> do rsid <- do roid <- either entityKey id <$> insertBy' (RemoteObject iid luActor) - either entityKey id <$> insertBy' (RemoteActor roid (actorName actor <|> actorUsername actor) (actorInbox actor) (actorFollowers actor) Nothing) + either entityKey id <$> insertBy' (RemoteActor roid (actorName detail <|> actorUsername detail) (actorInbox local) (actorFollowers local) Nothing) when vkExists $ insert_ $ VerifKeySharedUsage vkid rsid return $ Right rsid Just rsid -> runExceptT $ do @@ -494,14 +494,14 @@ actorFetchShareAction u (site, iid) = flip runWorkerT site $ do erecip <- fetchRecipient manager h lu for erecip $ \ recip -> case recip of - RecipientActor actor -> runSiteDB $ do + RecipientActor (Actor local detail) -> runSiteDB $ do roid <- either entityKey id <$> insertBy' (RemoteObject iid lu) let ra = RemoteActor { remoteActorIdent = roid , remoteActorName = - actorName actor <|> actorUsername actor - , remoteActorInbox = actorInbox actor - , remoteActorFollowers = actorFollowers actor + actorName detail <|> actorUsername detail + , remoteActorInbox = actorInbox local + , remoteActorFollowers = actorFollowers local , remoteActorErrorSince = Nothing } Just . either id (flip Entity ra) <$> insertBy' ra diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index e186032..bc43e8f 100644 --- a/src/Web/ActivityPub.hs +++ b/src/Web/ActivityPub.hs @@ -32,9 +32,11 @@ module Web.ActivityPub , PublicKey (..) , SshKeyAlgorithm (..) , SshPublicKey (..) + , ActorLocal (..) + , ActorDetail (..) , Actor (..) , Repo (..) - , Project (..) + , TicketTracker (..) , CollectionType (..) , Collection (..) , CollectionPageType (..) @@ -200,26 +202,26 @@ instance (ActivityPub a, UriMode u) => ToJSON (Doc a u) where context ts = "@context" .= ts data ActorType = - ActorTypePerson | ActorTypeRepo | ActorTypeProject | ActorTypeOther Text + ActorTypePerson | ActorTypeRepo | ActorTypeTicketTracker | ActorTypeOther Text deriving Eq instance FromJSON ActorType where parseJSON = withText "ActorType" $ pure . parse where parse t - | t == "Person" = ActorTypePerson - | t == "Repository" = ActorTypeRepo - | t == "Project" = ActorTypeProject - | otherwise = ActorTypeOther t + | t == "Person" = ActorTypePerson + | t == "Repository" = ActorTypeRepo + | t == "TicketTracker" = ActorTypeTicketTracker + | otherwise = ActorTypeOther t instance ToJSON ActorType where toJSON = error "toJSON ActorType" toEncoding at = toEncoding $ case at of - ActorTypePerson -> "Person" - ActorTypeRepo -> "Repository" - ActorTypeProject -> "Project" - ActorTypeOther t -> t + ActorTypePerson -> "Person" + ActorTypeRepo -> "Repository" + ActorTypeTicketTracker -> "TicketTracker" + ActorTypeOther t -> t data Owner = OwnerInstance | OwnerActor LocalURI @@ -360,12 +362,8 @@ instance ActivityPub SshPublicKey where <> "mediaType" .= ("application/octet-stream" :: Text) <> "content" .= decodeUtf8 (B64.encode mat) -data Actor u = Actor +data ActorLocal u = ActorLocal { actorId :: LocalURI - , actorType :: ActorType - , actorUsername :: Maybe Text - , actorName :: Maybe Text - , actorSummary :: Maybe Text , actorInbox :: LocalURI , actorOutbox :: Maybe LocalURI , actorFollowers :: Maybe LocalURI @@ -374,35 +372,83 @@ data Actor u = Actor , actorSshKeys :: [LocalURI] } +parseActorLocal :: UriMode u => Object -> Parser (Maybe (Authority u, ActorLocal u)) +parseActorLocal o = do + mid <- o .:? "id" + case mid of + Nothing -> do + verifyNothing "inbox" + verifyNothing "outbox" + verifyNothing "followers" + verifyNothing "following" + verifyNothing "publicKey" + verifyNothing "sshKey" + return Nothing + Just (ObjURI a id_) -> + fmap (Just . (a,)) $ + ActorLocal + <$> pure id_ + <*> withAuthorityO a (o .: "inbox") + <*> withAuthorityMaybeO a (o .:? "outbox") + <*> withAuthorityMaybeO a (o .:? "followers") + <*> withAuthorityMaybeO a (o .:? "following") + <*> withAuthorityT a (parsePublicKeySet =<< o .: "publicKey") + <*> (traverse (withAuthorityO a . return) =<< o .:? "sshKey" .!= []) + where + verifyNothing t = + if t `M.member` o + then fail $ T.unpack t ++ " field found, expected none" + else return () + +encodeActorLocal :: UriMode u => Authority u -> ActorLocal u -> Series +encodeActorLocal a (ActorLocal id_ inbox outbox followers following pkeys skeys) + = "id" .= ObjURI a id_ + <> "inbox" .= ObjURI a inbox + <> "outbox" .=? (ObjURI a <$> outbox) + <> "followers" .=? (ObjURI a <$> followers) + <> "following" .=? (ObjURI a <$> following) + <> "publicKey" `pair` encodePublicKeySet a pkeys + <> "sshKey" .=% map (ObjURI a) skeys + +data ActorDetail = ActorDetail + { actorType :: ActorType + , actorUsername :: Maybe Text + , actorName :: Maybe Text + , actorSummary :: Maybe Text + } + +parseActorDetail :: Object -> Parser ActorDetail +parseActorDetail o = + ActorDetail + <$> o .: "type" + <*> o .:? "preferredUsername" + <*> o .:? "name" + <*> o .:? "summary" + +encodeActorDetail :: ActorDetail -> Series +encodeActorDetail (ActorDetail typ musername mname msummary) + = "type" .= typ + <> "preferredUsername" .=? musername + <> "name" .=? mname + <> "summary" .=? msummary + +data Actor u = Actor + { actorLocal :: ActorLocal u + , actorDetail :: ActorDetail + } + instance ActivityPub Actor where jsonldContext _ = [as2Context, secContext, forgeContext, extContext] parseObject o = do - ObjURI authority id_ <- o .: "id" - fmap (authority,) $ - Actor id_ - <$> o .: "type" - <*> o .:? "preferredUsername" - <*> o .:? "name" - <*> o .:? "summary" - <*> 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 following pkeys skeys) - = "id" .= ObjURI authority id_ - <> "type" .= typ - <> "preferredUsername" .=? musername - <> "name" .=? mname - <> "summary" .=? msummary - <> "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 + mlocal <- parseActorLocal o + (h, local) <- + case mlocal of + Nothing -> fail "No ActorLocal" + Just l -> return l + detail <- parseActorDetail o + return (h, Actor local detail) + toSeries h (Actor local detail) = + encodeActorLocal h local <> encodeActorDetail detail data Repo u = Repo { repoActor :: Actor u @@ -414,7 +460,7 @@ instance ActivityPub Repo where jsonldContext _ = [as2Context, secContext, forgeContext] parseObject o = do (h, a) <- parseObject o - unless (actorType a == ActorTypeRepo) $ + unless (actorType (actorDetail a) == ActorTypeRepo) $ fail "Actor type isn't Repository" fmap (h,) $ Repo a @@ -425,21 +471,21 @@ instance ActivityPub Repo where <> "team" .= ObjURI authority team <> "versionControlSystem" .= vcs -data Project u = Project - { projectActor :: Actor u - , projectTeam :: LocalURI +data TicketTracker u = TicketTracker + { ticketTrackerActor :: Actor u + , ticketTrackerTeam :: LocalURI } instance ActivityPub Project where jsonldContext _ = [as2Context, secContext, forgeContext, extContext] parseObject o = do (h, a) <- parseObject o - unless (actorType a == ActorTypeProject) $ - fail "Actor type isn't Project" + unless (actorType (actorDetail a) == ActorTypeTicketTracker) $ + fail "Actor type isn't TicketTracker" fmap (h,) $ - Project a + TicketTracker a <$> withAuthorityO h (o .:| "team") - toSeries authority (Project actor team) + toSeries authority (TicketTracker actor team) = toSeries authority actor <> "team" .= ObjURI authority team @@ -1351,15 +1397,26 @@ encodeApply (Apply obj target) = "object" .= obj <> "target" .= target -data CreateObject u = CreateNote (Note u) | CreateTicket (Ticket u) +data CreateObject u + = CreateNote (Authority u) (Note u) + | CreateTicket (Authority u) (Ticket u) + | CreateTicketTracker ActorDetail (Maybe (Authority u, ActorLocal u)) -instance ActivityPub CreateObject where - jsonldContext = error "jsonldContext CreateObject" - parseObject o - = second CreateNote <$> parseObject o - <|> second CreateTicket <$> parseObject o - toSeries au (CreateNote o) = toSeries au o - toSeries au (CreateTicket o) = toSeries au o +parseCreateObject :: UriMode u => Object -> Parser (CreateObject u) +parseCreateObject o + = uncurry CreateNote <$> parseObject o + <|> uncurry CreateTicket <$> parseObject o + <|> do d <- parseActorDetail o + unless (actorType d == ActorTypeTicketTracker) $ + fail "type isn't TicketTracker" + ml <- parseActorLocal o + return $ CreateTicketTracker d ml + +encodeCreateObject :: UriMode u => CreateObject u -> Series +encodeCreateObject (CreateNote h note) = toSeries h note +encodeCreateObject (CreateTicket h ticket) = toSeries h ticket +encodeCreateObject (CreateTicketTracker d ml) = + encodeActorDetail d <> maybe mempty (uncurry encodeActorLocal) ml data Create u = Create { createObject :: CreateObject u @@ -1368,16 +1425,20 @@ data Create u = Create parseCreate :: UriMode u => Object -> Authority u -> LocalURI -> Parser (Create u) parseCreate o a luActor = do - obj <- withAuthorityT a $ parseObject =<< o .: "object" - unless (luActor == attrib obj) $ fail "Create actor != object attrib" + obj <- parseCreateObject =<< o .: "object" + case obj of + CreateNote h note -> + unless (a == h && luActor == noteAttrib note) $ + fail "Create actor != note attrib" + CreateTicket h ticket -> + unless (a == h && luActor == ticketAttributedTo ticket) $ + fail "Create actor != note attrib" + CreateTicketTracker _ _ -> return () Create obj <$> o .:? "target" - where - attrib (CreateNote note) = noteAttrib note - attrib (CreateTicket ticket) = ticketAttributedTo ticket -encodeCreate :: UriMode u => Authority u -> LocalURI -> Create u -> Series -encodeCreate authority actor (Create obj target) - = "object" `pair` pairs (toSeries authority obj) +encodeCreate :: UriMode u => Create u -> Series +encodeCreate (Create obj target) + = "object" `pair` pairs (encodeCreateObject obj) <> "target" .=? target data Follow u = Follow @@ -1575,7 +1636,7 @@ instance ActivityPub Activity where encodeSpecific h _ (AcceptActivity a) = encodeAccept h a encodeSpecific h _ (AddActivity a) = encodeAdd h a encodeSpecific _ _ (ApplyActivity a) = encodeApply a - encodeSpecific h u (CreateActivity a) = encodeCreate h u a + encodeSpecific _ _ (CreateActivity a) = encodeCreate a encodeSpecific _ _ (FollowActivity a) = encodeFollow a encodeSpecific h u (OfferActivity a) = encodeOffer h u a encodeSpecific h _ (PushActivity a) = encodePush h a @@ -1787,7 +1848,7 @@ fetchAPID' m getId h lu = runExceptT $ do fetchRecipient :: (MonadIO m, UriMode u) => Manager -> Authority u -> LocalURI -> m (Either (Maybe APGetError) (Recipient u)) fetchRecipient m = fetchAPID' m getId where - getId (RecipientActor a) = actorId a + getId (RecipientActor a) = actorId $ actorLocal a getId (RecipientCollection c) = collectionId c fetchAPID :: (MonadIO m, UriMode u, ActivityPub a) => Manager -> (a u -> LocalURI) -> Authority u -> LocalURI -> m (Either String (a u)) @@ -1844,7 +1905,7 @@ keyListedByActor -> LocalURI -> m (Either String (Actor u)) keyListedByActor manager host luKey luActor = runExceptT $ do - actor <- ExceptT $ fetchAPID manager actorId host luActor + actor <- ExceptT $ fetchAPID manager (actorId . actorLocal) host luActor if keyUriListed luKey actor then return actor else throwE "Actor publicKey has no URI matching pkey @id" @@ -1852,7 +1913,7 @@ keyListedByActor manager host luKey luActor = runExceptT $ do keyUriListed (LocalRefURI uk) a = let match (Left uri) = Left uri == uk match (Right _) = False - in any match $ actorPublicKeys a + in any match $ actorPublicKeys $ actorLocal a matchKeyObj :: (Foldable f, Monad m, UriMode u) @@ -1928,39 +1989,39 @@ fetchUnknownKey manager malgo host mluActor luKey = do then return () else throwE "Key's owner doesn't match actor header" return (False, owner) - actor <- ExceptT $ keyListedByActor manager host luKey luActor + Actor local detail <- ExceptT $ keyListedByActor manager host luKey luActor return Fetched { fetchedPublicKey = publicKeyMaterial pkey , fetchedKeyExpires = publicKeyExpires pkey , fetchedActorId = luActor - , fetchedActorName = actorName actor <|> actorUsername actor - , fetchedActorInbox = actorInbox actor - , fetchedActorFollowers = actorFollowers actor + , fetchedActorName = actorName detail <|> actorUsername detail + , fetchedActorInbox = actorInbox local + , fetchedActorFollowers = actorFollowers local , fetchedKeyShared = oi } - Right actor -> do + Right (Actor local detail) -> do case luKey of LocalRefURI (Right lsu) | - actorId actor == localSubUriResource lsu -> return () + actorId local == localSubUriResource lsu -> return () _ -> throwE "Actor ID doesn't match the keyid URI we fetched" for_ mluActor $ \ lu -> - if actorId actor == lu + if actorId local == lu then return () else throwE "Key's owner doesn't match actor header" - pk <- matchKeyObj luKey $ actorPublicKeys actor + pk <- matchKeyObj luKey $ actorPublicKeys local owner <- case publicKeyOwner pk of OwnerInstance -> throwE "Actor's publicKey is shared, but embedded in actor document! We allow shared keys only if they're in a separate document" OwnerActor owner -> - if owner == actorId actor + if owner == actorId local then return owner else throwE "Actor's publicKey's owner doesn't match the actor's ID" return Fetched { fetchedPublicKey = publicKeyMaterial pk , fetchedKeyExpires = publicKeyExpires pk , fetchedActorId = owner - , fetchedActorName = actorName actor <|> actorUsername actor - , fetchedActorInbox = actorInbox actor - , fetchedActorFollowers = actorFollowers actor + , fetchedActorName = actorName detail <|> actorUsername detail + , fetchedActorInbox = actorInbox local + , fetchedActorFollowers = actorFollowers local , fetchedKeyShared = False } ExceptT . pure $ verifyAlgo malgo $ fetchedPublicKey fetched @@ -1993,12 +2054,12 @@ fetchKnownPersonalKey manager malgo host luOwner luKey@(LocalRefURI ek) = do OwnerActor owner -> when (luOwner /= owner) $ throwE "Key owner changed" return $ keyDetail pkey - Right actor -> do - unless (Right (actorId actor) == second localSubUriResource ek) $ + Right (Actor local detail) -> do + unless (Right (actorId local) == second localSubUriResource ek) $ throwE "Actor ID doesn't match the keyid URI we fetched" - unless (actorId actor == luOwner) $ + unless (actorId local == luOwner) $ throwE "Key owner changed" - pk <- matchKeyObj luKey $ actorPublicKeys actor + pk <- matchKeyObj luKey $ actorPublicKeys local case publicKeyOwner pk of OwnerInstance -> throwE "Personal key became shared" OwnerActor owner ->