sup39/vervis
1
0
Fork 0
mirror of https://code.sup39.dev/repos/Wqawg synced 2024-12-27 18:34:52 +09:00
Code Issues Activity

Web.ActivityPub: Update representation of actor and project

Browse source 
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.
This commit is contained in:
fr33domlover 2022-07-24 16:52:28 +00:00
parent 88b8027572
commit e2591734d3
15 changed files with 241 additions and 166 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

6
src/Vervis/API.hs
View file

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

2
src/Vervis/ActivityPub.hs
View file

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

5
src/Vervis/Client.hs
View file

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

12
src/Vervis/Federation.hs
View file

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

2
src/Vervis/Federation/Discussion.hs
View file

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

2
src/Vervis/Federation/Offer.hs
View file

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

2
src/Vervis/Federation/Ticket.hs
View file

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

8
src/Vervis/Handler/Client.hs
View file

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

2
src/Vervis/Handler/Inbox.hs
View file

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

34
src/Vervis/Handler/Person.hs
View file

@ -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")

46
src/Vervis/Handler/Project.hs
View file

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

36
src/Vervis/Handler/Repo.hs
View file

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

3
src/Vervis/Migration.hs
View file

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

16
src/Vervis/RemoteActorStore.hs
View file

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

231
src/Web/ActivityPub.hs
View file

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