sup39/vervis
1
0
Fork 0
mirror of https://code.sup39.dev/repos/Wqawg synced 2024-12-29 02:14: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 Database.Persist.JSON
import Network.FedURI import Network.FedURI
import Network.HTTP.Digest 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.ActivityPub
import Yesod.Auth.Unverified import Yesod.Auth.Unverified
import Yesod.FedURI import Yesod.FedURI
@ -1099,7 +1099,7 @@ createNoteC (Entity pidUser personUser) sharerUser summary audience note muTarge
, activitySummary = summary , activitySummary = summary
, activityAudience = blinded , activityAudience = blinded
, activitySpecific = CreateActivity Create , activitySpecific = CreateActivity Create
{ createObject = CreateNote Note { createObject = CreateNote hLocal Note
{ noteId = Just $ encodeRouteLocal $ MessageR shrUser lmkhid { noteId = Just $ encodeRouteLocal $ MessageR shrUser lmkhid
, noteAttrib = luAttrib , noteAttrib = luAttrib
, noteAudience = emptyAudience , noteAudience = emptyAudience
@ -1680,7 +1680,7 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT
, activitySummary = summary , activitySummary = summary
, activityAudience = blinded , activityAudience = blinded
, activitySpecific = CreateActivity Create , activitySpecific = CreateActivity Create
{ createObject = CreateTicket AP.Ticket { createObject = CreateTicket hLocal AP.Ticket
{ AP.ticketLocal = Just (hLocal, tlocal) { AP.ticketLocal = Just (hLocal, tlocal)
, AP.ticketAttributedTo = luAttrib , AP.ticketAttributedTo = luAttrib
, AP.ticketPublished = Just now , AP.ticketPublished = Just now

2
src/Vervis/ActivityPub.hs
View file

@ -110,7 +110,7 @@ import Yesod.HttpSignature
import Database.Persist.JSON import Database.Persist.JSON
import Network.FedURI import Network.FedURI
import Network.HTTP.Digest 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.ActivityPub
import Yesod.MonadSite import Yesod.MonadSite
import Yesod.FedURI 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 Development.PatchMediaType
import Network.FedURI 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.ActivityPub
import Yesod.FedURI import Yesod.FedURI
import Yesod.Hashids import Yesod.Hashids
@ -305,6 +305,7 @@ createTicket shrAuthor (TextHtml title) (TextPandocMarkdown desc) target context
} }
encodeRouteLocal <- getEncodeRouteLocal encodeRouteLocal <- getEncodeRouteLocal
hLocal <- asksSite siteInstanceHost
descHtml <- ExceptT . pure $ renderPandocMarkdown desc descHtml <- ExceptT . pure $ renderPandocMarkdown desc
let ticket = AP.Ticket let ticket = AP.Ticket
{ AP.ticketLocal = Nothing { AP.ticketLocal = Nothing
@ -320,7 +321,7 @@ createTicket shrAuthor (TextHtml title) (TextPandocMarkdown desc) target context
, AP.ticketAttachment = Nothing , AP.ticketAttachment = Nothing
} }
create = Create create = Create
{ createObject = CreateTicket ticket { createObject = CreateTicket hLocal ticket
, createTarget = Just target , 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) _ -> return ("Unsupported add object type for sharers", Nothing)
CreateActivity (Create obj mtarget) -> CreateActivity (Create obj mtarget) ->
case obj of case obj of
CreateNote note -> CreateNote _ note ->
(,Nothing) <$> sharerCreateNoteF now shrRecip author body mfwd luActivity note (,Nothing) <$> sharerCreateNoteF now shrRecip author body mfwd luActivity note
CreateTicket ticket -> CreateTicket _ ticket ->
(,Nothing) <$> sharerCreateTicketF now shrRecip author body mfwd luActivity ticket mtarget (,Nothing) <$> sharerCreateTicketF now shrRecip author body mfwd luActivity ticket mtarget
_ -> return ("Unsupported create object type for sharers", Nothing) _ -> return ("Unsupported create object type for sharers", Nothing)
FollowActivity follow -> FollowActivity follow ->
@ -332,9 +332,9 @@ handleProjectInbox shrRecip prjRecip now auth body = do
case activitySpecific $ actbActivity body of case activitySpecific $ actbActivity body of
CreateActivity (Create obj mtarget) -> CreateActivity (Create obj mtarget) ->
case obj of case obj of
CreateNote note -> CreateNote _ note ->
(,Nothing) <$> projectCreateNoteF now shrRecip prjRecip remoteAuthor body mfwd luActivity 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 (,Nothing) <$> projectCreateTicketF now shrRecip prjRecip remoteAuthor body mfwd luActivity ticket mtarget
_ -> error "Unsupported create object type for projects" _ -> error "Unsupported create object type for projects"
FollowActivity follow -> FollowActivity follow ->
@ -391,9 +391,9 @@ handleRepoInbox shrRecip rpRecip now auth body = do
_ -> return ("Unsupported add object type for repos", Nothing) _ -> return ("Unsupported add object type for repos", Nothing)
CreateActivity (Create obj mtarget) -> CreateActivity (Create obj mtarget) ->
case obj of case obj of
CreateNote note -> CreateNote _ note ->
(,Nothing) <$> repoCreateNoteF now shrRecip rpRecip remoteAuthor body mfwd luActivity 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 (,Nothing) <$> repoCreateTicketF now shrRecip rpRecip remoteAuthor body mfwd luActivity ticket mtarget
_ -> error "Unsupported create object type for repos" _ -> error "Unsupported create object type for repos"
FollowActivity follow -> FollowActivity follow ->

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

@ -53,7 +53,7 @@ import Yesod.HttpSignature
import Database.Persist.JSON import Database.Persist.JSON
import Network.FedURI import Network.FedURI
import Network.HTTP.Digest import Network.HTTP.Digest
import Web.ActivityPub hiding (Project (..), Actor (..)) import Web.ActivityPub hiding (ActorLocal (..))
import Yesod.ActivityPub import Yesod.ActivityPub
import Yesod.FedURI import Yesod.FedURI
import Yesod.Hashids 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 Database.Persist.JSON
import Network.FedURI import Network.FedURI
import Web.ActivityPub hiding (Ticket (..), Follow, Project (..), Actor (..)) import Web.ActivityPub hiding (Ticket (..), Follow, Project (..), ActorLocal (..))
import Yesod.ActivityPub import Yesod.ActivityPub
import Yesod.FedURI import Yesod.FedURI
import Yesod.Hashids 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 Database.Persist.JSON
import Network.FedURI 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.ActivityPub
import Yesod.FedURI import Yesod.FedURI
import Yesod.Hashids 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 applyC eperson sharer summary audience mcap apply
CreateActivity (Create obj mtarget) -> CreateActivity (Create obj mtarget) ->
case obj of case obj of
CreateNote note -> CreateNote _ note ->
createNoteC eperson sharer summary audience note mtarget createNoteC eperson sharer summary audience note mtarget
CreateTicket ticket -> CreateTicket _ ticket ->
createTicketC eperson sharer summary audience ticket mtarget createTicketC eperson sharer summary audience ticket mtarget
_ -> throwE "Unsupported Create 'object' type" _ -> throwE "Unsupported Create 'object' type"
FollowActivity follow -> FollowActivity follow ->
@ -529,7 +529,7 @@ postPublishR = do
ExceptT $ C.createTicket (sharerIdent sharer) title desc target context ExceptT $ C.createTicket (sharerIdent sharer) title desc target context
let ticket = let ticket =
case createObject create of case createObject create of
CreateTicket t -> t CreateTicket _ t -> t
_ -> error "Create object isn't a ticket" _ -> error "Create object isn't a ticket"
target = createTarget create target = createTarget create
createTicketC eperson sharer (Just summary) audience ticket target 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 ExceptT $ createTicket shrAuthor (TextHtml title) (TextPandocMarkdown desc) project project
let ticket = let ticket =
case obj of case obj of
CreateTicket t -> t CreateTicket _ t -> t
_ -> error "Create object isn't a ticket" _ -> error "Create object isn't a ticket"
obiid <- createTicketC eperson sharer (Just summary) audience ticket mtarget obiid <- createTicketC eperson sharer (Just summary) audience ticket mtarget
ExceptT $ runDB $ do 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 Database.Persist.JSON
import Network.FedURI import Network.FedURI
import Web.ActivityPub hiding (Project (..), Actor (..)) import Web.ActivityPub hiding (Project (..), ActorLocal (..))
import Yesod.ActivityPub import Yesod.ActivityPub
import Yesod.Auth.Unverified import Yesod.Auth.Unverified
import Yesod.FedURI import Yesod.FedURI

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

@ -135,11 +135,8 @@ getPerson shr sharer (Entity pid person) = do
encodeKeyHashid <- getEncodeKeyHashid encodeKeyHashid <- getEncodeKeyHashid
skids <- runDB $ P.selectKeysList [SshKeyPerson P.==. pid] [P.Asc SshKeyId] skids <- runDB $ P.selectKeysList [SshKeyPerson P.==. pid] [P.Asc SshKeyId]
let personAP = Actor let personAP = Actor
{ actorLocal = ActorLocal
{ actorId = encodeRouteLocal $ SharerR shr { actorId = encodeRouteLocal $ SharerR shr
, actorType = ActorTypePerson
, actorUsername = Just $ shr2text shr
, actorName = sharerName sharer
, actorSummary = Nothing
, actorInbox = encodeRouteLocal $ SharerInboxR shr , actorInbox = encodeRouteLocal $ SharerInboxR shr
, actorOutbox = Just $ encodeRouteLocal $ SharerOutboxR shr , actorOutbox = Just $ encodeRouteLocal $ SharerOutboxR shr
, actorFollowers = Just $ encodeRouteLocal $ SharerFollowersR shr , actorFollowers = Just $ encodeRouteLocal $ SharerFollowersR shr
@ -151,6 +148,13 @@ getPerson shr sharer (Entity pid person) = do
, actorSshKeys = , actorSshKeys =
map (encodeRouteLocal . SshKeyR shr . encodeKeyHashid) skids map (encodeRouteLocal . SshKeyR shr . encodeKeyHashid) skids
} }
, actorDetail = ActorDetail
{ actorType = ActorTypePerson
, actorUsername = Just $ shr2text shr
, actorName = sharerName sharer
, actorSummary = Nothing
}
}
secure <- getSecure secure <- getSecure
provideHtmlAndAP personAP $(widgetFile "person") provideHtmlAndAP personAP $(widgetFile "person")
where where

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

@ -51,7 +51,7 @@ import qualified Database.Esqueleto as E
import Database.Persist.JSON import Database.Persist.JSON
import Network.FedURI import Network.FedURI
import Web.ActivityPub hiding (Project (..), Repo (..), Actor (..)) import Web.ActivityPub hiding (Project (..), Repo (..), Actor (..), ActorDetail (..), ActorLocal (..))
import Yesod.ActivityPub import Yesod.ActivityPub
import Yesod.FedURI import Yesod.FedURI
import Yesod.MonadSite import Yesod.MonadSite
@ -161,14 +161,10 @@ getProjectR shar proj = do
route2fed <- getEncodeRouteHome route2fed <- getEncodeRouteHome
route2local <- getEncodeRouteLocal route2local <- getEncodeRouteLocal
let projectAP = AP.Project let projectAP = AP.TicketTracker
{ AP.projectActor = AP.Actor { AP.ticketTrackerActor = AP.Actor
{ AP.actorLocal = AP.ActorLocal
{ AP.actorId = route2local $ ProjectR shar proj { 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.actorInbox = route2local $ ProjectInboxR shar proj
, AP.actorOutbox = , AP.actorOutbox =
Just $ route2local $ ProjectOutboxR shar proj Just $ route2local $ ProjectOutboxR shar proj
@ -181,7 +177,15 @@ getProjectR shar proj = do
] ]
, AP.actorSshKeys = [] , AP.actorSshKeys = []
} }
, AP.projectTeam = route2local $ ProjectTeamR shar proj , AP.actorDetail = AP.ActorDetail
{ AP.actorType = ActorTypeTicketTracker
, AP.actorUsername = Nothing
, AP.actorName =
Just $ fromMaybe (prj2text proj) $ projectName project
, AP.actorSummary = projectDesc project
}
}
, AP.ticketTrackerTeam = route2local $ ProjectTeamR shar proj
} }
followButton = followButton =
followW followW

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

@ -239,11 +239,8 @@ getRepoR shr rp = do
encodeRouteHome <- getEncodeRouteHome encodeRouteHome <- getEncodeRouteHome
let repoAP = AP.Repo let repoAP = AP.Repo
{ AP.repoActor = Actor { AP.repoActor = Actor
{ actorLocal = ActorLocal
{ actorId = encodeRouteLocal $ RepoR shr rp { actorId = encodeRouteLocal $ RepoR shr rp
, actorType = ActorTypeRepo
, actorUsername = Nothing
, actorName = Just $ rp2text rp
, actorSummary = repoDesc repo
, actorInbox = encodeRouteLocal $ RepoInboxR shr rp , actorInbox = encodeRouteLocal $ RepoInboxR shr rp
, actorOutbox = , actorOutbox =
Just $ encodeRouteLocal $ RepoOutboxR shr rp Just $ encodeRouteLocal $ RepoOutboxR shr rp
@ -256,6 +253,13 @@ getRepoR shr rp = do
] ]
, actorSshKeys = [] , actorSshKeys = []
} }
, actorDetail = ActorDetail
{ actorType = ActorTypeRepo
, actorUsername = Nothing
, actorName = Just $ rp2text rp
, actorSummary = repoDesc repo
}
}
, AP.repoTeam = encodeRouteLocal $ RepoTeamR shr rp , AP.repoTeam = encodeRouteLocal $ RepoTeamR shr rp
, AP.repoVcs = repoVcs repo , AP.repoVcs = repoVcs repo
} }

3
src/Vervis/Migration.hs
View file

@ -470,7 +470,7 @@ changes hLocal ctx =
, activitySummary = Nothing , activitySummary = Nothing
, activityAudience = aud , activityAudience = aud
, activitySpecific = CreateActivity Create , activitySpecific = CreateActivity Create
{ createObject = CreateNote Note { createObject = CreateNote hLocal Note
{ noteId = Just luNote { noteId = Just luNote
, noteAttrib = luAttrib , noteAttrib = luAttrib
, noteAudience = aud , noteAudience = aud
@ -771,6 +771,7 @@ changes hLocal ctx =
, ticketAssignedTo = Nothing , ticketAssignedTo = Nothing
, ticketResolved = Nothing , ticketResolved = Nothing
, ticketAttachment = Nothing , ticketAttachment = Nothing
, ticketContext = Nothing
} }
summary = summary =
[hamlet| [hamlet|

16
src/Vervis/RemoteActorStore.hs
View file

@ -339,10 +339,10 @@ keyListedByActorShared iid vkid host luKey luActor = do
case roomMode of case roomMode of
RoomModeInstant -> do RoomModeInstant -> do
when reject $ throwE "Actor key storage limit is 0 and set to reject" 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 lift $ runDB $ do
roid <- either entityKey id <$> insertBy' (RemoteObject iid luActor) 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 RoomModeCached m -> do
eresult <- do eresult <- do
ments <- lift $ runDB $ do ments <- lift $ runDB $ do
@ -362,14 +362,14 @@ keyListedByActorShared iid vkid host luKey luActor = do
case eresult of case eresult of
Left rsid -> return rsid Left rsid -> return rsid
Right mrsid -> do Right mrsid -> do
actor <- ExceptT (keyListedByActor manager host luKey luActor) Actor local detail <- ExceptT (keyListedByActor manager host luKey luActor)
ExceptT $ runDB $ do ExceptT $ runDB $ do
vkExists <- isJust <$> get vkid vkExists <- isJust <$> get vkid
case mrsid of case mrsid of
Nothing -> do Nothing -> do
rsid <- do rsid <- do
roid <- either entityKey id <$> insertBy' (RemoteObject iid luActor) 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 when vkExists $ insert_ $ VerifKeySharedUsage vkid rsid
return $ Right rsid return $ Right rsid
Just rsid -> runExceptT $ do Just rsid -> runExceptT $ do
@ -494,14 +494,14 @@ actorFetchShareAction u (site, iid) = flip runWorkerT site $ do
erecip <- fetchRecipient manager h lu erecip <- fetchRecipient manager h lu
for erecip $ \ recip -> for erecip $ \ recip ->
case recip of case recip of
RecipientActor actor -> runSiteDB $ do RecipientActor (Actor local detail) -> runSiteDB $ do
roid <- either entityKey id <$> insertBy' (RemoteObject iid lu) roid <- either entityKey id <$> insertBy' (RemoteObject iid lu)
let ra = RemoteActor let ra = RemoteActor
{ remoteActorIdent = roid { remoteActorIdent = roid
, remoteActorName = , remoteActorName =
actorName actor <|> actorUsername actor actorName detail <|> actorUsername detail
, remoteActorInbox = actorInbox actor , remoteActorInbox = actorInbox local
, remoteActorFollowers = actorFollowers actor , remoteActorFollowers = actorFollowers local
, remoteActorErrorSince = Nothing , remoteActorErrorSince = Nothing
} }
Just . either id (flip Entity ra) <$> insertBy' ra Just . either id (flip Entity ra) <$> insertBy' ra

211
src/Web/ActivityPub.hs
View file

@ -32,9 +32,11 @@ module Web.ActivityPub
, PublicKey (..) , PublicKey (..)
, SshKeyAlgorithm (..) , SshKeyAlgorithm (..)
, SshPublicKey (..) , SshPublicKey (..)
, ActorLocal (..)
, ActorDetail (..)
, Actor (..) , Actor (..)
, Repo (..) , Repo (..)
, Project (..) , TicketTracker (..)
, CollectionType (..) , CollectionType (..)
, Collection (..) , Collection (..)
, CollectionPageType (..) , CollectionPageType (..)
@ -200,7 +202,7 @@ instance (ActivityPub a, UriMode u) => ToJSON (Doc a u) where
context ts = "@context" .= ts context ts = "@context" .= ts
data ActorType = data ActorType =
ActorTypePerson | ActorTypeRepo | ActorTypeProject | ActorTypeOther Text ActorTypePerson | ActorTypeRepo | ActorTypeTicketTracker | ActorTypeOther Text
deriving Eq deriving Eq
instance FromJSON ActorType where instance FromJSON ActorType where
@ -209,7 +211,7 @@ instance FromJSON ActorType where
parse t parse t
| t == "Person" = ActorTypePerson | t == "Person" = ActorTypePerson
| t == "Repository" = ActorTypeRepo | t == "Repository" = ActorTypeRepo
| t == "Project" = ActorTypeProject | t == "TicketTracker" = ActorTypeTicketTracker
| otherwise = ActorTypeOther t | otherwise = ActorTypeOther t
instance ToJSON ActorType where instance ToJSON ActorType where
@ -218,7 +220,7 @@ instance ToJSON ActorType where
toEncoding $ case at of toEncoding $ case at of
ActorTypePerson -> "Person" ActorTypePerson -> "Person"
ActorTypeRepo -> "Repository" ActorTypeRepo -> "Repository"
ActorTypeProject -> "Project" ActorTypeTicketTracker -> "TicketTracker"
ActorTypeOther t -> t ActorTypeOther t -> t
data Owner = OwnerInstance | OwnerActor LocalURI data Owner = OwnerInstance | OwnerActor LocalURI
@ -360,12 +362,8 @@ instance ActivityPub SshPublicKey where
<> "mediaType" .= ("application/octet-stream" :: Text) <> "mediaType" .= ("application/octet-stream" :: Text)
<> "content" .= decodeUtf8 (B64.encode mat) <> "content" .= decodeUtf8 (B64.encode mat)
data Actor u = Actor data ActorLocal u = ActorLocal
{ actorId :: LocalURI { actorId :: LocalURI
, actorType :: ActorType
, actorUsername :: Maybe Text
, actorName :: Maybe Text
, actorSummary :: Maybe Text
, actorInbox :: LocalURI , actorInbox :: LocalURI
, actorOutbox :: Maybe LocalURI , actorOutbox :: Maybe LocalURI
, actorFollowers :: Maybe LocalURI , actorFollowers :: Maybe LocalURI
@ -374,35 +372,83 @@ data Actor u = Actor
, actorSshKeys :: [LocalURI] , actorSshKeys :: [LocalURI]
} }
instance ActivityPub Actor where parseActorLocal :: UriMode u => Object -> Parser (Maybe (Authority u, ActorLocal u))
jsonldContext _ = [as2Context, secContext, forgeContext, extContext] parseActorLocal o = do
parseObject o = do mid <- o .:? "id"
ObjURI authority id_ <- o .: "id" case mid of
fmap (authority,) $ Nothing -> do
Actor id_ 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 .: "type"
<*> o .:? "preferredUsername" <*> o .:? "preferredUsername"
<*> o .:? "name" <*> o .:? "name"
<*> o .:? "summary" <*> o .:? "summary"
<*> withAuthorityO authority (o .: "inbox")
<*> withAuthorityMaybeO authority (o .:? "outbox") encodeActorDetail :: ActorDetail -> Series
<*> withAuthorityMaybeO authority (o .:? "followers") encodeActorDetail (ActorDetail typ musername mname msummary)
<*> withAuthorityMaybeO authority (o .:? "following") = "type" .= typ
<*> 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 <> "preferredUsername" .=? musername
<> "name" .=? mname <> "name" .=? mname
<> "summary" .=? msummary <> "summary" .=? msummary
<> "inbox" .= ObjURI authority inbox
<> "outbox" .=? (ObjURI authority <$> outbox) data Actor u = Actor
<> "followers" .=? (ObjURI authority <$> followers) { actorLocal :: ActorLocal u
<> "following" .=? (ObjURI authority <$> following) , actorDetail :: ActorDetail
<> "publicKey" `pair` encodePublicKeySet authority pkeys }
<> "sshKey" .=% map (ObjURI authority) skeys
instance ActivityPub Actor where
jsonldContext _ = [as2Context, secContext, forgeContext, extContext]
parseObject o = do
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 data Repo u = Repo
{ repoActor :: Actor u { repoActor :: Actor u
@ -414,7 +460,7 @@ instance ActivityPub Repo where
jsonldContext _ = [as2Context, secContext, forgeContext] jsonldContext _ = [as2Context, secContext, forgeContext]
parseObject o = do parseObject o = do
(h, a) <- parseObject o (h, a) <- parseObject o
unless (actorType a == ActorTypeRepo) $ unless (actorType (actorDetail a) == ActorTypeRepo) $
fail "Actor type isn't Repository" fail "Actor type isn't Repository"
fmap (h,) $ fmap (h,) $
Repo a Repo a
@ -425,21 +471,21 @@ instance ActivityPub Repo where
<> "team" .= ObjURI authority team <> "team" .= ObjURI authority team
<> "versionControlSystem" .= vcs <> "versionControlSystem" .= vcs
data Project u = Project data TicketTracker u = TicketTracker
{ projectActor :: Actor u { ticketTrackerActor :: Actor u
, projectTeam :: LocalURI , ticketTrackerTeam :: LocalURI
} }
instance ActivityPub Project where instance ActivityPub Project where
jsonldContext _ = [as2Context, secContext, forgeContext, extContext] jsonldContext _ = [as2Context, secContext, forgeContext, extContext]
parseObject o = do parseObject o = do
(h, a) <- parseObject o (h, a) <- parseObject o
unless (actorType a == ActorTypeProject) $ unless (actorType (actorDetail a) == ActorTypeTicketTracker) $
fail "Actor type isn't Project" fail "Actor type isn't TicketTracker"
fmap (h,) $ fmap (h,) $
Project a TicketTracker a
<$> withAuthorityO h (o .:| "team") <$> withAuthorityO h (o .:| "team")
toSeries authority (Project actor team) toSeries authority (TicketTracker actor team)
= toSeries authority actor = toSeries authority actor
<> "team" .= ObjURI authority team <> "team" .= ObjURI authority team
@ -1351,15 +1397,26 @@ encodeApply (Apply obj target)
= "object" .= obj = "object" .= obj
<> "target" .= target <> "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 parseCreateObject :: UriMode u => Object -> Parser (CreateObject u)
jsonldContext = error "jsonldContext CreateObject" parseCreateObject o
parseObject o = uncurry CreateNote <$> parseObject o
= second CreateNote <$> parseObject o <|> uncurry CreateTicket <$> parseObject o
<|> second CreateTicket <$> parseObject o <|> do d <- parseActorDetail o
toSeries au (CreateNote o) = toSeries au o unless (actorType d == ActorTypeTicketTracker) $
toSeries au (CreateTicket o) = toSeries au o 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 data Create u = Create
{ createObject :: CreateObject u { createObject :: CreateObject u
@ -1368,16 +1425,20 @@ data Create u = Create
parseCreate :: UriMode u => Object -> Authority u -> LocalURI -> Parser (Create u) parseCreate :: UriMode u => Object -> Authority u -> LocalURI -> Parser (Create u)
parseCreate o a luActor = do parseCreate o a luActor = do
obj <- withAuthorityT a $ parseObject =<< o .: "object" obj <- parseCreateObject =<< o .: "object"
unless (luActor == attrib obj) $ fail "Create actor != object attrib" 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" 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 :: UriMode u => Create u -> Series
encodeCreate authority actor (Create obj target) encodeCreate (Create obj target)
= "object" `pair` pairs (toSeries authority obj) = "object" `pair` pairs (encodeCreateObject obj)
<> "target" .=? target <> "target" .=? target
data Follow u = Follow data Follow u = Follow
@ -1575,7 +1636,7 @@ instance ActivityPub Activity where
encodeSpecific h _ (AcceptActivity a) = encodeAccept h a encodeSpecific h _ (AcceptActivity a) = encodeAccept h a
encodeSpecific h _ (AddActivity a) = encodeAdd h a encodeSpecific h _ (AddActivity a) = encodeAdd h a
encodeSpecific _ _ (ApplyActivity a) = encodeApply 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 _ _ (FollowActivity a) = encodeFollow a
encodeSpecific h u (OfferActivity a) = encodeOffer h u a encodeSpecific h u (OfferActivity a) = encodeOffer h u a
encodeSpecific h _ (PushActivity a) = encodePush h 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 :: (MonadIO m, UriMode u) => Manager -> Authority u -> LocalURI -> m (Either (Maybe APGetError) (Recipient u))
fetchRecipient m = fetchAPID' m getId fetchRecipient m = fetchAPID' m getId
where where
getId (RecipientActor a) = actorId a getId (RecipientActor a) = actorId $ actorLocal a
getId (RecipientCollection c) = collectionId c getId (RecipientCollection c) = collectionId c
fetchAPID :: (MonadIO m, UriMode u, ActivityPub a) => Manager -> (a u -> LocalURI) -> Authority u -> LocalURI -> m (Either String (a u)) 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 -> LocalURI
-> m (Either String (Actor u)) -> m (Either String (Actor u))
keyListedByActor manager host luKey luActor = runExceptT $ do 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 if keyUriListed luKey actor
then return actor then return actor
else throwE "Actor publicKey has no URI matching pkey @id" 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 = keyUriListed (LocalRefURI uk) a =
let match (Left uri) = Left uri == uk let match (Left uri) = Left uri == uk
match (Right _) = False match (Right _) = False
in any match $ actorPublicKeys a in any match $ actorPublicKeys $ actorLocal a
matchKeyObj matchKeyObj
:: (Foldable f, Monad m, UriMode u) :: (Foldable f, Monad m, UriMode u)
@ -1928,39 +1989,39 @@ fetchUnknownKey manager malgo host mluActor luKey = do
then return () then return ()
else throwE "Key's owner doesn't match actor header" else throwE "Key's owner doesn't match actor header"
return (False, owner) return (False, owner)
actor <- ExceptT $ keyListedByActor manager host luKey luActor Actor local detail <- ExceptT $ keyListedByActor manager host luKey luActor
return Fetched return Fetched
{ fetchedPublicKey = publicKeyMaterial pkey { fetchedPublicKey = publicKeyMaterial pkey
, fetchedKeyExpires = publicKeyExpires pkey , fetchedKeyExpires = publicKeyExpires pkey
, fetchedActorId = luActor , fetchedActorId = luActor
, fetchedActorName = actorName actor <|> actorUsername actor , fetchedActorName = actorName detail <|> actorUsername detail
, fetchedActorInbox = actorInbox actor , fetchedActorInbox = actorInbox local
, fetchedActorFollowers = actorFollowers actor , fetchedActorFollowers = actorFollowers local
, fetchedKeyShared = oi , fetchedKeyShared = oi
} }
Right actor -> do Right (Actor local detail) -> do
case luKey of case luKey of
LocalRefURI (Right lsu) | LocalRefURI (Right lsu) |
actorId actor == localSubUriResource lsu -> return () actorId local == localSubUriResource lsu -> return ()
_ -> throwE "Actor ID doesn't match the keyid URI we fetched" _ -> throwE "Actor ID doesn't match the keyid URI we fetched"
for_ mluActor $ \ lu -> for_ mluActor $ \ lu ->
if actorId actor == lu if actorId local == lu
then return () then return ()
else throwE "Key's owner doesn't match actor header" 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 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" 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 -> OwnerActor owner ->
if owner == actorId actor if owner == actorId local
then return owner then return owner
else throwE "Actor's publicKey's owner doesn't match the actor's ID" else throwE "Actor's publicKey's owner doesn't match the actor's ID"
return Fetched return Fetched
{ fetchedPublicKey = publicKeyMaterial pk { fetchedPublicKey = publicKeyMaterial pk
, fetchedKeyExpires = publicKeyExpires pk , fetchedKeyExpires = publicKeyExpires pk
, fetchedActorId = owner , fetchedActorId = owner
, fetchedActorName = actorName actor <|> actorUsername actor , fetchedActorName = actorName detail <|> actorUsername detail
, fetchedActorInbox = actorInbox actor , fetchedActorInbox = actorInbox local
, fetchedActorFollowers = actorFollowers actor , fetchedActorFollowers = actorFollowers local
, fetchedKeyShared = False , fetchedKeyShared = False
} }
ExceptT . pure $ verifyAlgo malgo $ fetchedPublicKey fetched ExceptT . pure $ verifyAlgo malgo $ fetchedPublicKey fetched
@ -1993,12 +2054,12 @@ fetchKnownPersonalKey manager malgo host luOwner luKey@(LocalRefURI ek) = do
OwnerActor owner -> OwnerActor owner ->
when (luOwner /= owner) $ throwE "Key owner changed" when (luOwner /= owner) $ throwE "Key owner changed"
return $ keyDetail pkey return $ keyDetail pkey
Right actor -> do Right (Actor local detail) -> do
unless (Right (actorId actor) == second localSubUriResource ek) $ unless (Right (actorId local) == second localSubUriResource ek) $
throwE "Actor ID doesn't match the keyid URI we fetched" throwE "Actor ID doesn't match the keyid URI we fetched"
unless (actorId actor == luOwner) $ unless (actorId local == luOwner) $
throwE "Key owner changed" throwE "Key owner changed"
pk <- matchKeyObj luKey $ actorPublicKeys actor pk <- matchKeyObj luKey $ actorPublicKeys local
case publicKeyOwner pk of case publicKeyOwner pk of
OwnerInstance -> throwE "Personal key became shared" OwnerInstance -> throwE "Personal key became shared"
OwnerActor owner -> OwnerActor owner ->