Improve the AP async HTTP delivery API and per-actor key support
New iteration of the ActivityPub delivery implementation and interface. Advantages over previous interface: * When sending a ByteString body, the sender is explicitly passed as a parameter instead of JSON-parsing it out of the ByteString * Clear 3 operations provided: Send, Resend and Forward * Support for per-actor keys * Actor-type-specific functions (e.g. deliverRemoteDB_D) removed * Only the most high-level API is exposed to Activity handler code, making handler code more concise and clear Also added in this patch: * Foundation for per-actor key support * 1 key per actor allowed in DB * Disabled C2S and S2S handlers now un-exported for clarity * Audience and capability parsing automatically done for all C2S handlers * Audience and activity composition automatically done for Vervis.Client builder functions Caveats: * Actor documents still don't link to their per-actor keys; that should be the last piece to complete per-actor key support * No moderation and anti-spam tools yet * Delivery API doesn't yet have good integration of persistence layer, e.g. activity is separately encoded into bytestring for DB and for HTTP; this will be improved in the next iteration * Periodic delivery now done in 3 separate steps, running sequentially; it simplifies the code, but may be changed for efficiency/robustness in the next iterations * Periodic delivery collects per-actor keys in a 1-DB-transaction-for-each-delivery fashion, rather than grabbing them in the big Esqueleto query (or keeping the signed output in the DB; this isn't done currently to allow for smooth actor key renewal) * No support yet in the API for delivery where the actor key has already been fetched, rather than doing a DB transaction to grab it; such support would be just an optimization, so it's low-priority, but will be added in later iterations
This commit is contained in:
fr33domlover
parent
3c7b9f33e4
commit
32c87e3839
36 changed files with 2197 additions and 1584 deletions
|
|
@ -40,6 +40,9 @@ actor-key-rotation:
|
|||
amount: 1
|
||||
unit: days
|
||||
|
||||
# Whether to use personal actor keys, or an instance-wide key
|
||||
per-actor-keys: false
|
||||
|
||||
###############################################################################
|
||||
# Development
|
||||
###############################################################################
|
||||
|
|
|
|||
5
migrations/497_2022-09-29_sigkey.model
Normal file
5
migrations/497_2022-09-29_sigkey.model
Normal file
|
|
@ -0,0 +1,5 @@
|
|||
SigKey
|
||||
actor ActorId
|
||||
material ActorKey
|
||||
|
||||
UniqueSigKey actor
|
||||
121
migrations/498_2022-10-03_forwarder.model
Normal file
121
migrations/498_2022-10-03_forwarder.model
Normal file
|
|
@ -0,0 +1,121 @@
|
|||
RemoteActor
|
||||
RemoteActivity
|
||||
Role
|
||||
OutboxItem
|
||||
Workflow
|
||||
|
||||
Forwarding
|
||||
recipient RemoteActorId
|
||||
activity RemoteActivityId
|
||||
activityRaw ByteString
|
||||
signature ByteString
|
||||
forwarder ActorId
|
||||
running Bool
|
||||
|
||||
UniqueForwarding recipient activity
|
||||
|
||||
ForwarderPerson
|
||||
task ForwardingId
|
||||
sender PersonId
|
||||
|
||||
UniqueForwarderPerson task
|
||||
|
||||
ForwarderGroup
|
||||
task ForwardingId
|
||||
sender GroupId
|
||||
|
||||
UniqueForwarderGroup task
|
||||
|
||||
ForwarderRepo
|
||||
task ForwardingId
|
||||
sender RepoId
|
||||
|
||||
UniqueForwarderRepo task
|
||||
|
||||
ForwarderLoom
|
||||
task ForwardingId
|
||||
sender LoomId
|
||||
|
||||
UniqueForwarderLoom task
|
||||
|
||||
ForwarderDeck
|
||||
task ForwardingId
|
||||
sender DeckId
|
||||
|
||||
UniqueForwarderDeck task
|
||||
|
||||
Person
|
||||
username Username
|
||||
login Text
|
||||
passphraseHash ByteString
|
||||
email EmailAddress
|
||||
verified Bool
|
||||
verifiedKey Text
|
||||
verifiedKeyCreated UTCTime
|
||||
resetPassKey Text
|
||||
resetPassKeyCreated UTCTime
|
||||
actor ActorId
|
||||
-- reviewFollow Bool
|
||||
|
||||
UniquePersonUsername username
|
||||
UniquePersonLogin login
|
||||
UniquePersonEmail email
|
||||
UniquePersonActor actor
|
||||
|
||||
Group
|
||||
actor ActorId
|
||||
|
||||
UniqueGroupActor actor
|
||||
|
||||
Repo
|
||||
vcs VersionControlSystem
|
||||
project DeckId Maybe
|
||||
mainBranch Text
|
||||
collabUser RoleId Maybe
|
||||
collabAnon RoleId Maybe
|
||||
actor ActorId
|
||||
create OutboxItemId
|
||||
loom LoomId Maybe
|
||||
|
||||
UniqueRepoActor actor
|
||||
UniqueRepoCreate create
|
||||
|
||||
Deck
|
||||
actor ActorId
|
||||
workflow WorkflowId
|
||||
nextTicket Int
|
||||
wiki RepoId Maybe
|
||||
collabUser RoleId Maybe
|
||||
collabAnon RoleId Maybe
|
||||
create OutboxItemId
|
||||
|
||||
UniqueDeckActor actor
|
||||
UniqueDeckCreate create
|
||||
|
||||
Loom
|
||||
nextTicket Int
|
||||
actor ActorId
|
||||
repo RepoId
|
||||
create OutboxItemId
|
||||
|
||||
UniqueLoomActor actor
|
||||
UniqueLoomRepo repo
|
||||
UniqueLoomCreate create
|
||||
|
||||
Actor
|
||||
name Text
|
||||
desc Text
|
||||
createdAt UTCTime
|
||||
inbox InboxId
|
||||
outbox OutboxId
|
||||
followers FollowerSetId
|
||||
|
||||
UniqueActorInbox inbox
|
||||
UniqueActorOutbox outbox
|
||||
UniqueActorFollowers followers
|
||||
|
||||
Outbox
|
||||
|
||||
Inbox
|
||||
|
||||
FollowerSet
|
||||
|
|
@ -13,13 +13,13 @@
|
|||
- <http://creativecommons.org/publicdomain/zero/1.0/>.
|
||||
-}
|
||||
|
||||
module Vervis.ActorKey
|
||||
module Crypto.ActorKey
|
||||
( ActorKey ()
|
||||
, generateActorKey
|
||||
, actorKeyRotator
|
||||
, actorKeyPublicBin
|
||||
, actorKeySign
|
||||
-- , actorKeyVerify
|
||||
, actorKeyVerify
|
||||
)
|
||||
where
|
||||
|
||||
|
|
@ -195,3 +195,7 @@ actorKeyPublicBin = fromEd25519 . actorKeyPublic
|
|||
|
||||
actorKeySign :: ActorKey -> ByteString -> Signature
|
||||
actorKeySign (ActorKey sec pub) = Signature . convert . sign sec pub
|
||||
|
||||
actorKeyVerify :: ActorKey -> ByteString -> Signature -> Either String Bool
|
||||
actorKeyVerify akey input (Signature sig) =
|
||||
verifySignature (actorKeyPublicBin akey) input sig
|
||||
|
|
@ -1,6 +1,6 @@
|
|||
{- This file is part of Vervis.
|
||||
-
|
||||
- Written in 2019, 2020 by fr33domlover <fr33domlover@riseup.net>.
|
||||
- Written in 2019, 2020, 2022 by fr33domlover <fr33domlover@riseup.net>.
|
||||
-
|
||||
- ♡ Copying is an act of love. Please copy, reuse and share.
|
||||
-
|
||||
|
|
@ -17,6 +17,7 @@ module Data.Tuple.Local
|
|||
( fst3
|
||||
, fst4
|
||||
, fst5
|
||||
, fst6
|
||||
, thd3
|
||||
, fourth4
|
||||
, fourth5
|
||||
|
|
@ -32,6 +33,9 @@ fst4 (x, _, _, _) = x
|
|||
fst5 :: (a, b, c, d, e) -> a
|
||||
fst5 (x, _, _, _, _) = x
|
||||
|
||||
fst6 :: (a, b, c, d, e, f) -> a
|
||||
fst6 (x, _, _, _, _, _) = x
|
||||
|
||||
thd3 :: (a, b, c) -> c
|
||||
thd3 (_, _, z) = z
|
||||
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
{- This file is part of Vervis.
|
||||
-
|
||||
- Written 2019 by fr33domlover <fr33domlover@riseup.net>.
|
||||
- Written 2019, 2022 by fr33domlover <fr33domlover@riseup.net>.
|
||||
-
|
||||
- ♡ Copying is an act of love. Please copy, reuse and share.
|
||||
-
|
||||
|
|
@ -35,6 +35,7 @@ module Network.FedURI
|
|||
, PageURI (..)
|
||||
, RefURI (..)
|
||||
, parseRefURI
|
||||
, renderRefURI
|
||||
)
|
||||
where
|
||||
|
||||
|
|
@ -570,6 +571,9 @@ parseRefURI = toRefURI <=< toFullRefURI <=< parseFullURI
|
|||
uriFromRefURI :: UriMode t => RefURI t -> URI
|
||||
uriFromRefURI = fromFullURI . fromFullRefURI . fromRefURI
|
||||
|
||||
renderRefURI :: UriMode t => RefURI t -> Text
|
||||
renderRefURI = renderFullURI . fromFullRefURI . fromRefURI
|
||||
|
||||
instance UriMode t => FromJSON (RefURI t) where
|
||||
parseJSON = either fail return . toRefURI <=< parseJSON
|
||||
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load diff
|
|
@ -83,7 +83,9 @@ import Dvara
|
|||
import Yesod.Mail.Send (runMailer)
|
||||
|
||||
import Control.Concurrent.ResultShare
|
||||
import Crypto.ActorKey
|
||||
import Data.KeyFile
|
||||
import Development.PatchMediaType
|
||||
import Network.FedURI
|
||||
import Yesod.Hashids
|
||||
import Yesod.MonadSite
|
||||
|
|
@ -92,9 +94,8 @@ import Control.Concurrent.Local
|
|||
import Data.List.NonEmpty.Local
|
||||
import Web.Hashids.Local
|
||||
|
||||
import Vervis.ActorKey (generateActorKey, actorKeyRotator)
|
||||
import Vervis.Darcs
|
||||
import Vervis.Delivery
|
||||
import Vervis.Web.Delivery
|
||||
import Vervis.Foundation
|
||||
import Vervis.Git
|
||||
import Vervis.Hook
|
||||
|
|
@ -122,8 +123,8 @@ import Vervis.Handler.Ticket
|
|||
import Vervis.Migration (migrateDB)
|
||||
import Vervis.Model
|
||||
import Vervis.Model.Ident
|
||||
import Development.PatchMediaType
|
||||
import Vervis.Path
|
||||
import Vervis.Persist.Actor
|
||||
import Vervis.Settings
|
||||
import Vervis.Ssh (runSsh)
|
||||
|
||||
|
|
@ -160,8 +161,14 @@ makeFoundation appSettings = do
|
|||
else loadFont "data/LinLibertineCut.svg"
|
||||
|
||||
appActorKeys <-
|
||||
newTVarIO =<<
|
||||
(,,) <$> generateActorKey <*> generateActorKey <*> pure True
|
||||
if appPerActorKeys appSettings
|
||||
then pure Nothing
|
||||
else Just <$> do
|
||||
keys <- (,,)
|
||||
<$> generateActorKey
|
||||
<*> generateActorKey
|
||||
<*> pure True
|
||||
newTVarIO keys
|
||||
|
||||
appInstanceMutex <- newInstanceMutex
|
||||
|
||||
|
|
@ -346,9 +353,9 @@ getAppSettings = loadYamlSettings [configSettingsYml] [] useEnv
|
|||
develMain :: IO ()
|
||||
develMain = develMainHelper getApplicationDev
|
||||
|
||||
actorKeyPeriodicRotator :: App -> IO ()
|
||||
actorKeyPeriodicRotator :: App -> Maybe (IO ())
|
||||
actorKeyPeriodicRotator app =
|
||||
actorKeyRotator (appActorKeyRotation $ appSettings app) (appActorKeys app)
|
||||
actorKeyRotator (appActorKeyRotation $ appSettings app) <$> appActorKeys app
|
||||
|
||||
deliveryRunner :: App -> IO ()
|
||||
deliveryRunner app =
|
||||
|
|
@ -399,7 +406,11 @@ appMain = do
|
|||
app <- makeApplication foundation
|
||||
|
||||
-- Run actor signature key periodic generation thread
|
||||
forkCheck $ actorKeyPeriodicRotator foundation
|
||||
traverse_ forkCheck $ actorKeyPeriodicRotator foundation
|
||||
|
||||
-- If we're using per-actor keys, generate keys for local actors that don't
|
||||
-- have a key and insert to DB
|
||||
runWorker fillPerActorKeys foundation
|
||||
|
||||
-- Run periodic activity delivery retry runner
|
||||
when (appFederation $ appSettings foundation) $
|
||||
|
|
|
|||
|
|
@ -14,7 +14,9 @@
|
|||
-}
|
||||
|
||||
module Vervis.Client
|
||||
( --createThread
|
||||
( makeServerInput
|
||||
|
||||
--, createThread
|
||||
--, createReply
|
||||
--, follow
|
||||
--, followSharer
|
||||
|
|
@ -28,7 +30,7 @@ module Vervis.Client
|
|||
--, undoFollowTicket
|
||||
--, undoFollowRepo
|
||||
--, unresolve
|
||||
offerPatches
|
||||
, offerPatches
|
||||
, offerMerge
|
||||
, applyPatches
|
||||
, createDeck
|
||||
|
|
@ -85,6 +87,31 @@ import Vervis.RemoteActorStore
|
|||
import Vervis.Ticket
|
||||
import Vervis.WorkItem
|
||||
|
||||
makeServerInput
|
||||
:: (MonadSite m, SiteEnv m ~ App)
|
||||
=> Maybe FedURI
|
||||
-> Maybe HTML
|
||||
-> [Aud URIMode]
|
||||
-> AP.SpecificActivity URIMode
|
||||
-> m ( RecipientRoutes
|
||||
, [(Host, NonEmpty LocalURI)]
|
||||
, [Host]
|
||||
, AP.Action URIMode
|
||||
)
|
||||
makeServerInput maybeCapURI maybeSummary audience specific = do
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
|
||||
collectAudience audience
|
||||
recips = map encodeRouteHome audLocal ++ audRemote
|
||||
action = AP.Action
|
||||
{ AP.actionCapability = maybeCapURI
|
||||
, AP.actionSummary = maybeSummary
|
||||
, AP.actionAudience = AP.Audience recips [] [] [] [] []
|
||||
, AP.actionFulfills = []
|
||||
, AP.actionSpecific = specific
|
||||
}
|
||||
return (recipientSet, remoteActors, fwdHosts, action)
|
||||
|
||||
{-
|
||||
createThread
|
||||
:: (MonadSite m, SiteEnv m ~ App)
|
||||
|
|
@ -547,7 +574,7 @@ offerPatches
|
|||
-> Maybe Text
|
||||
-> PatchMediaType
|
||||
-> NonEmpty Text
|
||||
-> ExceptT Text Handler (Maybe HTML, AP.Audience URIMode, AP.Ticket URIMode)
|
||||
-> ExceptT Text Handler (Maybe HTML, [Aud URIMode], AP.Ticket URIMode)
|
||||
offerPatches senderHash title desc uTracker uTargetRepo maybeBranch typ diffs = do
|
||||
|
||||
tracker <- do
|
||||
|
|
@ -567,7 +594,6 @@ offerPatches senderHash title desc uTracker uTargetRepo maybeBranch typ diffs =
|
|||
descHtml <- ExceptT . pure $ renderPandocMarkdown desc
|
||||
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
hLocal <- asksSite siteInstanceHost
|
||||
|
||||
let audAuthor =
|
||||
|
|
@ -583,10 +609,7 @@ offerPatches senderHash title desc uTracker uTargetRepo maybeBranch typ diffs =
|
|||
[luTracker]
|
||||
(maybeToList $ remoteActorFollowers remoteActor)
|
||||
|
||||
|
||||
(_, _, _, audLocal, audRemote) =
|
||||
collectAudience [audAuthor, audTracker]
|
||||
recips = map encodeRouteHome audLocal ++ audRemote
|
||||
audience = [audAuthor, audTracker]
|
||||
|
||||
luSender = encodeRouteLocal $ PersonR senderHash
|
||||
ObjURI hTargetRepo luTargetRepo = uTargetRepo
|
||||
|
|
@ -630,7 +653,7 @@ offerPatches senderHash title desc uTracker uTargetRepo maybeBranch typ diffs =
|
|||
)
|
||||
}
|
||||
|
||||
return (Nothing, AP.Audience recips [] [] [] [] [], ticket)
|
||||
return (Nothing, audience, ticket)
|
||||
|
||||
offerMerge
|
||||
:: KeyHashid Person
|
||||
|
|
@ -641,7 +664,7 @@ offerMerge
|
|||
-> Maybe Text
|
||||
-> FedURI
|
||||
-> Maybe Text
|
||||
-> ExceptT Text Handler (Maybe HTML, AP.Audience URIMode, AP.Ticket URIMode)
|
||||
-> ExceptT Text Handler (Maybe HTML, [Aud URIMode], AP.Ticket URIMode)
|
||||
offerMerge senderHash title desc uTracker uTargetRepo maybeTargetBranch uOriginRepo maybeOriginBranch = do
|
||||
|
||||
tracker <- do
|
||||
|
|
@ -661,7 +684,6 @@ offerMerge senderHash title desc uTracker uTargetRepo maybeTargetBranch uOriginR
|
|||
descHtml <- ExceptT . pure $ renderPandocMarkdown desc
|
||||
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
hLocal <- asksSite siteInstanceHost
|
||||
|
||||
let audAuthor =
|
||||
|
|
@ -677,10 +699,7 @@ offerMerge senderHash title desc uTracker uTargetRepo maybeTargetBranch uOriginR
|
|||
[luTracker]
|
||||
(maybeToList $ remoteActorFollowers remoteActor)
|
||||
|
||||
|
||||
(_, _, _, audLocal, audRemote) =
|
||||
collectAudience [audAuthor, audTracker]
|
||||
recips = map encodeRouteHome audLocal ++ audRemote
|
||||
audience = [audAuthor, audTracker]
|
||||
|
||||
ObjURI hTargetRepo luTargetRepo = uTargetRepo
|
||||
ObjURI hOriginRepo luOriginRepo = uOriginRepo
|
||||
|
|
@ -722,12 +741,12 @@ offerMerge senderHash title desc uTracker uTargetRepo maybeTargetBranch uOriginR
|
|||
)
|
||||
}
|
||||
|
||||
return (Nothing, AP.Audience recips [] [] [] [] [], ticket)
|
||||
return (Nothing, audience, ticket)
|
||||
|
||||
applyPatches
|
||||
:: KeyHashid Person
|
||||
-> FedURI
|
||||
-> ExceptT Text Handler (Maybe HTML, Audience URIMode, Apply URIMode)
|
||||
-> ExceptT Text Handler (Maybe HTML, [Aud URIMode], Apply URIMode)
|
||||
applyPatches senderHash uObject = do
|
||||
|
||||
bundle <- parseProposalBundle "Apply object" uObject
|
||||
|
|
@ -818,27 +837,21 @@ applyPatches senderHash uObject = do
|
|||
[luTracker]
|
||||
(catMaybes [mluFollowers, Just luTicketFollowers])
|
||||
|
||||
(_, _, _, audLocal, audRemote) = collectAudience [audAuthor, audCloth]
|
||||
audience = [audAuthor, audCloth]
|
||||
|
||||
recips = map encodeRouteHome audLocal ++ audRemote
|
||||
|
||||
return (Nothing, Audience recips [] [] [] [] [], Apply uObject target)
|
||||
return (Nothing, audience, Apply uObject target)
|
||||
|
||||
createDeck
|
||||
:: (MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App)
|
||||
=> KeyHashid Person
|
||||
-> Text
|
||||
-> Text
|
||||
-> m (Maybe HTML, Audience URIMode, AP.ActorDetail)
|
||||
-> m (Maybe HTML, [Aud URIMode], AP.ActorDetail)
|
||||
createDeck senderHash name desc = do
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
|
||||
let audAuthor =
|
||||
AudLocal [] [LocalStagePersonFollowers senderHash]
|
||||
|
||||
(_, _, _, audLocal, audRemote) = collectAudience [audAuthor]
|
||||
|
||||
recips = map encodeRouteHome audLocal ++ audRemote
|
||||
audience = [audAuthor]
|
||||
|
||||
detail = AP.ActorDetail
|
||||
{ AP.actorType = AP.ActorTypeTicketTracker
|
||||
|
|
@ -847,7 +860,7 @@ createDeck senderHash name desc = do
|
|||
, AP.actorSummary = Just desc
|
||||
}
|
||||
|
||||
return (Nothing, AP.Audience recips [] [] [] [] [], detail)
|
||||
return (Nothing, audience, detail)
|
||||
|
||||
createLoom
|
||||
:: (MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App)
|
||||
|
|
@ -855,7 +868,7 @@ createLoom
|
|||
-> Text
|
||||
-> Text
|
||||
-> KeyHashid Repo
|
||||
-> m (Maybe HTML, Audience URIMode, AP.ActorDetail, NonEmpty FedURI)
|
||||
-> m (Maybe HTML, [Aud URIMode], AP.ActorDetail, NonEmpty FedURI)
|
||||
createLoom senderHash name desc repoHash = do
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
|
||||
|
|
@ -866,9 +879,7 @@ createLoom senderHash name desc repoHash = do
|
|||
[LocalActorRepo repoHash]
|
||||
[LocalStageRepoFollowers repoHash]
|
||||
|
||||
(_, _, _, audLocal, audRemote) = collectAudience [audAuthor, audRepo]
|
||||
|
||||
recips = map encodeRouteHome audLocal ++ audRemote
|
||||
audience = [audAuthor, audRepo]
|
||||
|
||||
detail = AP.ActorDetail
|
||||
{ AP.actorType = AP.ActorTypePatchTracker
|
||||
|
|
@ -878,23 +889,19 @@ createLoom senderHash name desc repoHash = do
|
|||
}
|
||||
repo = encodeRouteHome $ RepoR repoHash
|
||||
|
||||
return (Nothing, AP.Audience recips [] [] [] [] [], detail, repo :| [])
|
||||
return (Nothing, audience, detail, repo :| [])
|
||||
|
||||
createRepo
|
||||
:: (MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App)
|
||||
=> KeyHashid Person
|
||||
-> Text
|
||||
-> Text
|
||||
-> m (Maybe HTML, Audience URIMode, AP.ActorDetail)
|
||||
-> m (Maybe HTML, [Aud URIMode], AP.ActorDetail)
|
||||
createRepo senderHash name desc = do
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
|
||||
let audAuthor =
|
||||
AudLocal [] [LocalStagePersonFollowers senderHash]
|
||||
|
||||
(_, _, _, audLocal, audRemote) = collectAudience [audAuthor]
|
||||
|
||||
recips = map encodeRouteHome audLocal ++ audRemote
|
||||
audience = [audAuthor]
|
||||
|
||||
detail = AP.ActorDetail
|
||||
{ AP.actorType = AP.ActorTypeRepo
|
||||
|
|
@ -903,4 +910,4 @@ createRepo senderHash name desc = do
|
|||
, AP.actorSummary = Just desc
|
||||
}
|
||||
|
||||
return (Nothing, AP.Audience recips [] [] [] [] [], detail)
|
||||
return (Nothing, audience, detail)
|
||||
|
|
|
|||
|
|
@ -17,6 +17,8 @@ module Vervis.Data.Actor
|
|||
( parseLocalActivityURI
|
||||
, parseActivityURI
|
||||
, activityRoute
|
||||
, stampRoute
|
||||
, parseStampRoute
|
||||
)
|
||||
where
|
||||
|
||||
|
|
@ -80,3 +82,17 @@ activityRoute (LocalActorGroup g) = GroupOutboxItemR g
|
|||
activityRoute (LocalActorRepo r) = RepoOutboxItemR r
|
||||
activityRoute (LocalActorDeck d) = DeckOutboxItemR d
|
||||
activityRoute (LocalActorLoom l) = LoomOutboxItemR l
|
||||
|
||||
stampRoute :: LocalActorBy KeyHashid -> KeyHashid SigKey -> Route App
|
||||
stampRoute (LocalActorPerson p) = PersonStampR p
|
||||
stampRoute (LocalActorGroup g) = GroupStampR g
|
||||
stampRoute (LocalActorRepo r) = RepoStampR r
|
||||
stampRoute (LocalActorDeck d) = DeckStampR d
|
||||
stampRoute (LocalActorLoom l) = LoomStampR l
|
||||
|
||||
parseStampRoute (PersonStampR p i) = Just (LocalActorPerson p, i)
|
||||
parseStampRoute (GroupStampR g i) = Just (LocalActorGroup g, i)
|
||||
parseStampRoute (RepoStampR r i) = Just (LocalActorRepo r, i)
|
||||
parseStampRoute (DeckStampR d i) = Just (LocalActorDeck d, i)
|
||||
parseStampRoute (LoomStampR l i) = Just (LocalActorLoom l, i)
|
||||
parseStampRoute _ = Nothing
|
||||
|
|
|
|||
|
|
@ -94,7 +94,7 @@ import Yesod.Persist.Local
|
|||
|
||||
import Vervis.ActivityPub
|
||||
import Vervis.ActorKey
|
||||
import Vervis.Delivery
|
||||
import Vervis.Web.Delivery
|
||||
import Vervis.Federation.Auth
|
||||
import Vervis.Foundation
|
||||
import Vervis.Model
|
||||
|
|
|
|||
|
|
@ -72,6 +72,7 @@ import Data.Time.Interval
|
|||
import Network.HTTP.Signature hiding (requestHeaders)
|
||||
import Yesod.HttpSignature
|
||||
|
||||
import Crypto.ActorKey
|
||||
import Crypto.PublicVerifKey
|
||||
import Database.Persist.JSON
|
||||
import Network.FedURI
|
||||
|
|
@ -94,7 +95,7 @@ import Database.Persist.Local
|
|||
import Yesod.Persist.Local
|
||||
|
||||
import Vervis.ActivityPub
|
||||
import Vervis.ActorKey
|
||||
import Vervis.Data.Actor
|
||||
import Vervis.FedURI
|
||||
import Vervis.Foundation
|
||||
import Vervis.Model
|
||||
|
|
@ -261,21 +262,14 @@ verifyActorSig (Verification malgo keyid input signature) = do
|
|||
Right lu
|
||||
_ -> throwE "Multiple ActivityPub-Actor headers"
|
||||
|
||||
verifySelfSig
|
||||
:: LocalURI
|
||||
verifySelfSigIK
|
||||
:: TVar (ActorKey, ActorKey, Bool)
|
||||
-> LocalActorBy Key
|
||||
-> LocalRefURI
|
||||
-> ByteString
|
||||
-> Signature
|
||||
-> ExceptT String Handler (LocalActorBy Key)
|
||||
verifySelfSig luAuthor (LocalRefURI lruKey) input (Signature sig) = do
|
||||
author <- do
|
||||
route <-
|
||||
fromMaybeE
|
||||
(decodeRouteLocal luAuthor)
|
||||
"Local author ID isn't a valid route"
|
||||
fromMaybeE
|
||||
(parseLocalActor route)
|
||||
"Local author ID isn't an actor route"
|
||||
-> ExceptT String Handler ()
|
||||
verifySelfSigIK instanceKeys authorByKey (LocalRefURI lruKey) input sig = do
|
||||
akey <- do
|
||||
route <- do
|
||||
luKey <-
|
||||
|
|
@ -285,34 +279,82 @@ verifySelfSig luAuthor (LocalRefURI lruKey) input (Signature sig) = do
|
|||
fromMaybeE
|
||||
(decodeRouteLocal luKey)
|
||||
"Local key ID isn't a valid route"
|
||||
(akey1, akey2, _) <- liftIO . readTVarIO =<< getsYesod appActorKeys
|
||||
(akey1, akey2, _) <- liftIO $ readTVarIO instanceKeys
|
||||
case route of
|
||||
ActorKey1R -> return akey1
|
||||
ActorKey2R -> return akey2
|
||||
_ -> throwE "Local key ID isn't an actor key route"
|
||||
valid <-
|
||||
ExceptT . pure $ verifySignature (actorKeyPublicBin akey) input sig
|
||||
_ -> throwE "Local key ID isn't an instance key route"
|
||||
valid <- ExceptT . pure $ actorKeyVerify akey input sig
|
||||
unless valid $
|
||||
throwE "Self sig verification says not valid"
|
||||
localAuth <- unhashLocalActorE author "No such actor"
|
||||
withExceptT T.unpack $ runDBExcept $ findLocalAuthInDB localAuth
|
||||
return localAuth
|
||||
withExceptT T.unpack $ runDBExcept $ findLocalAuthInDB authorByKey
|
||||
where
|
||||
findLocalAuthInDB (LocalActorPerson pid) = do
|
||||
mp <- lift $ get pid
|
||||
when (isNothing mp) $ throwE "No such person"
|
||||
findLocalAuthInDB (LocalActorGroup gid) = do
|
||||
mg <- lift $ get gid
|
||||
when (isNothing mg) $ throwE "No such group"
|
||||
findLocalAuthInDB (LocalActorRepo rid) = do
|
||||
mr <- lift $ get rid
|
||||
when (isNothing mr) $ throwE "No such repo"
|
||||
findLocalAuthInDB (LocalActorDeck did) = do
|
||||
md <- lift $ get did
|
||||
when (isNothing md) $ throwE "No such deck"
|
||||
findLocalAuthInDB (LocalActorLoom lid) = do
|
||||
ml <- lift $ get lid
|
||||
when (isNothing ml) $ throwE "No such loom"
|
||||
findLocalAuthInDB actor = do
|
||||
ma <- lift $ getLocalActorID actor
|
||||
when (isNothing ma) $ throwE "No such actor in DB"
|
||||
|
||||
verifySelfSigAK
|
||||
:: LocalActorBy Key
|
||||
-> LocalRefURI
|
||||
-> ByteString
|
||||
-> Signature
|
||||
-> ExceptT String Handler ()
|
||||
verifySelfSigAK authorByKey (LocalRefURI lruKey) input sig = do
|
||||
keyID <- do
|
||||
luKey <-
|
||||
case lruKey of
|
||||
Left l -> return l
|
||||
Right _ -> throwE "Local key ID has a fragment"
|
||||
route <-
|
||||
fromMaybeE
|
||||
(decodeRouteLocal luKey)
|
||||
"Local key ID isn't a valid route"
|
||||
(holderByHash, keyHash) <-
|
||||
fromMaybeE
|
||||
(parseStampRoute route)
|
||||
"Local key ID isn't an actor key route"
|
||||
holderByKey <-
|
||||
unhashLocalActorE
|
||||
holderByHash
|
||||
"Local key ID invalid holder keyhashid"
|
||||
keyID <-
|
||||
decodeKeyHashidE keyHash "Local key ID invalid sigkey keyhashid"
|
||||
unless (holderByKey == authorByKey) $
|
||||
throwE "Key belongs to someone else"
|
||||
return keyID
|
||||
akey <- withExceptT T.unpack $ runDBExcept $ do
|
||||
actorID <- do
|
||||
ma <- lift $ getLocalActorID authorByKey
|
||||
fromMaybeE ma "No such actor in DB"
|
||||
SigKey holderID akey <- getE keyID "No such key in DB"
|
||||
unless (actorID == holderID) $ throwE "Key belongs to someone else"
|
||||
return akey
|
||||
valid <- ExceptT . pure $ actorKeyVerify akey input sig
|
||||
unless valid $
|
||||
throwE "Self sig verification says not valid"
|
||||
|
||||
verifySelfSig
|
||||
:: LocalURI
|
||||
-> LocalRefURI
|
||||
-> ByteString
|
||||
-> Signature
|
||||
-> ExceptT String Handler (LocalActorBy Key)
|
||||
verifySelfSig luAuthor lruKey input sig = do
|
||||
authorByKey <- do
|
||||
route <-
|
||||
fromMaybeE
|
||||
(decodeRouteLocal luAuthor)
|
||||
"Local author ID isn't a valid route"
|
||||
authorByHash <-
|
||||
fromMaybeE
|
||||
(parseLocalActor route)
|
||||
"Local author ID isn't an actor route"
|
||||
unhashLocalActorE authorByHash "No such actor"
|
||||
maybeKeys <- asksSite appActorKeys
|
||||
case maybeKeys of
|
||||
Nothing -> verifySelfSigAK authorByKey lruKey input sig
|
||||
Just keys -> verifySelfSigIK keys authorByKey lruKey input sig
|
||||
return authorByKey
|
||||
|
||||
verifyForwardedSig
|
||||
:: Host
|
||||
|
|
|
|||
|
|
@ -73,7 +73,7 @@ import Vervis.Access
|
|||
import Vervis.ActivityPub
|
||||
import Vervis.Data.Actor
|
||||
import Vervis.Data.Collab
|
||||
import Vervis.Delivery
|
||||
import Vervis.Web.Delivery
|
||||
import Vervis.FedURI
|
||||
import Vervis.Federation.Auth
|
||||
import Vervis.Federation.Util
|
||||
|
|
@ -163,22 +163,18 @@ personInviteF now recipHash author body mfwd luInvite invite = (,Nothing) <$> do
|
|||
if inviteeIsRecip
|
||||
then makeRecipientSet [] [LocalStagePersonFollowers recipHash]
|
||||
else makeRecipientSet [] []
|
||||
remoteRecips <-
|
||||
insertRemoteActivityToLocalInboxes
|
||||
False inviteID $
|
||||
localRecipSieve'
|
||||
sieve False False localRecips
|
||||
(sig,) <$> deliverRemoteDB_P (actbBL body) inviteID personRecipID sig remoteRecips
|
||||
forwardActivityDB
|
||||
(actbBL body) localRecips sig (personActor personRecip)
|
||||
(LocalActorPerson recipHash) sieve inviteID
|
||||
|
||||
-- Launch asynchronous HTTP forwarding of the Invite activity
|
||||
case mhttp of
|
||||
Nothing -> return "I already have this activity in my inbox, doing nothing"
|
||||
Just mremotesHttpFwd -> do
|
||||
for_ mremotesHttpFwd $ \ (sig, remotes) ->
|
||||
forkWorker "personInviteF inbox-forwarding" $
|
||||
deliverRemoteHTTP_P now recipHash (actbBL body) sig remotes
|
||||
Just maybeForwardHttpInvite -> do
|
||||
for_ maybeForwardHttpInvite $
|
||||
forkWorker "personInviteF inbox-forwarding"
|
||||
return $
|
||||
case mremotesHttpFwd of
|
||||
case maybeForwardHttpInvite of
|
||||
Nothing -> "Inserted to inbox, no inbox-forwarding to do"
|
||||
Just _ -> "Inserted to inbox and ran inbox-forwarding of the Invite"
|
||||
|
||||
|
|
@ -282,26 +278,13 @@ topicInviteF now recipByHash author body mfwd luInvite invite = do
|
|||
-- and schedule delivery for unavailable remote members of
|
||||
-- them
|
||||
for mfwd $ \ (localRecips, sig) -> do
|
||||
let sieve =
|
||||
makeRecipientSet [] [localActorFollowers $ grantResourceLocalActor recipByHash]
|
||||
remoteRecips <-
|
||||
insertRemoteActivityToLocalInboxes
|
||||
False inviteID $
|
||||
localRecipSieve'
|
||||
sieve False False localRecips
|
||||
case recipByKey of
|
||||
GrantResourceRepo repoID -> do
|
||||
repoHash <- encodeKeyHashid repoID
|
||||
fwds <- deliverRemoteDB_R (actbBL body) inviteID repoID sig remoteRecips
|
||||
return $ deliverRemoteHTTP_R now repoHash (actbBL body) sig fwds
|
||||
GrantResourceDeck deckID -> do
|
||||
deckHash <- encodeKeyHashid deckID
|
||||
fwds <- deliverRemoteDB_D (actbBL body) inviteID deckID sig remoteRecips
|
||||
return $ deliverRemoteHTTP_D now deckHash (actbBL body) sig fwds
|
||||
GrantResourceLoom loomID -> do
|
||||
loomHash <- encodeKeyHashid loomID
|
||||
fwds <- deliverRemoteDB_L (actbBL body) inviteID loomID sig remoteRecips
|
||||
return $ deliverRemoteHTTP_L now loomHash (actbBL body) sig fwds
|
||||
let recipLocalActor =
|
||||
grantResourceLocalActor recipByHash
|
||||
sieve =
|
||||
makeRecipientSet [] [localActorFollowers recipLocalActor]
|
||||
forwardActivityDB
|
||||
(actbBL body) localRecips sig recipActorID
|
||||
recipLocalActor sieve inviteID
|
||||
|
||||
-- Launch asynchronous HTTP forwarding of the Invite activity
|
||||
case mhttp of
|
||||
|
|
@ -335,21 +318,6 @@ topicAcceptF
|
|||
:: (PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic)
|
||||
=> (topic -> ActorId)
|
||||
-> (forall f. f topic -> GrantResourceBy f)
|
||||
-> ( BL.ByteString
|
||||
-> RemoteActivityId
|
||||
-> Key topic
|
||||
-> ByteString
|
||||
-> [((InstanceId, Host), NonEmpty RemoteRecipient)]
|
||||
-> ReaderT SqlBackend Handler
|
||||
[((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId, Key fwder))]
|
||||
)
|
||||
-> ( UTCTime
|
||||
-> KeyHashid topic
|
||||
-> BL.ByteString
|
||||
-> ByteString
|
||||
-> [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId, Key fwder))]
|
||||
-> Worker ()
|
||||
)
|
||||
-> UTCTime
|
||||
-> KeyHashid topic
|
||||
-> RemoteAuthor
|
||||
|
|
@ -358,7 +326,7 @@ topicAcceptF
|
|||
-> LocalURI
|
||||
-> AP.Accept URIMode
|
||||
-> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
|
||||
topicAcceptF topicActor topicResource deliverRemoteDB deliverRemoteHTTP now recipHash author body mfwd luAccept accept = (,Nothing) <$> do
|
||||
topicAcceptF topicActor topicResource now recipHash author body mfwd luAccept accept = (,Nothing) <$> do
|
||||
|
||||
-- Check input
|
||||
acceptee <- parseAccept accept
|
||||
|
|
@ -428,74 +396,54 @@ topicAcceptF topicActor topicResource deliverRemoteDB deliverRemoteHTTP now reci
|
|||
|
||||
-- Forward the Accept activity to relevant local stages, and
|
||||
-- schedule delivery for unavailable remote members of them
|
||||
maybeRemotesHttpFwdAccept <- lift $ for mfwd $ \ (localRecips, sig) -> do
|
||||
let recipByHash = grantResourceLocalActor $ topicResource recipHash
|
||||
maybeHttpFwdAccept <- lift $ for mfwd $ \ (localRecips, sig) -> do
|
||||
let sieve =
|
||||
makeRecipientSet [] [localActorFollowers $ grantResourceLocalActor $ topicResource recipHash]
|
||||
remoteRecips <-
|
||||
insertRemoteActivityToLocalInboxes
|
||||
False acceptID $
|
||||
localRecipSieve'
|
||||
sieve False False localRecips
|
||||
(sig,) <$> deliverRemoteDB (actbBL body) acceptID recipKey sig remoteRecips
|
||||
makeRecipientSet [] [localActorFollowers recipByHash]
|
||||
forwardActivityDB
|
||||
(actbBL body) localRecips sig recipActorID recipByHash
|
||||
sieve acceptID
|
||||
|
||||
remotesHttpGrant <- lift $ do
|
||||
deliverHttpGrant <- do
|
||||
|
||||
-- Enable the Collab in our DB
|
||||
grantID <- insertEmptyOutboxItem (actorOutbox recipActor) now
|
||||
insert_ $ CollabEnable collabID grantID
|
||||
grantID <- lift $ insertEmptyOutboxItem (actorOutbox recipActor) now
|
||||
lift $ insert_ $ CollabEnable collabID grantID
|
||||
|
||||
-- Prepare a Grant activity and insert to topic's outbox
|
||||
(docGrant, localRecipsGrant, remoteRecipsGrant, fwdHostsGrant) <-
|
||||
insertGrantToOutbox inviteSender grantID
|
||||
(actionGrant, localRecipsGrant, remoteRecipsGrant, fwdHostsGrant) <-
|
||||
lift $ prepareGrant inviteSender
|
||||
let recipByKey = grantResourceLocalActor $ topicResource recipKey
|
||||
_luGrant <- lift $ updateOutboxItem recipByKey grantID actionGrant
|
||||
|
||||
-- Deliver the Grant to local recipients, and schedule delivery
|
||||
-- for unavailable remote recipients
|
||||
(grantID, docGrant, fwdHostsGrant,) <$> do
|
||||
knownRemoteRecipsGrant <-
|
||||
deliverLocal'
|
||||
False
|
||||
(grantResourceLocalActor $ topicResource recipHash)
|
||||
recipActorID
|
||||
grantID
|
||||
localRecipsGrant
|
||||
deliverRemoteDB'' fwdHostsGrant grantID remoteRecipsGrant knownRemoteRecipsGrant
|
||||
deliverActivityDB
|
||||
recipByHash recipActorID localRecipsGrant remoteRecipsGrant
|
||||
fwdHostsGrant grantID actionGrant
|
||||
|
||||
return (maybeRemotesHttpFwdAccept, remotesHttpGrant)
|
||||
return (maybeHttpFwdAccept, deliverHttpGrant)
|
||||
|
||||
-- Launch asynchronous HTTP forwarding of the Accept activity
|
||||
case mhttp of
|
||||
Nothing -> return "I already have this activity in my inbox, doing nothing"
|
||||
Just (mremotesHttpFwd, (grantID, docGrant, fwdHostsGrant, recipsGrant)) -> do
|
||||
forkWorker "topicAcceptF Grant HTTP delivery" $
|
||||
deliverRemoteHttp' fwdHostsGrant grantID docGrant recipsGrant
|
||||
case mremotesHttpFwd of
|
||||
Just (mhttpFwd, deliverHttpGrant) -> do
|
||||
forkWorker "topicAcceptF Grant HTTP delivery" deliverHttpGrant
|
||||
case mhttpFwd of
|
||||
Nothing -> return "Sent a Grant, no inbox-forwarding to do"
|
||||
Just (sig, remotes) -> do
|
||||
forkWorker "topicAcceptF inbox-forwarding" $
|
||||
deliverRemoteHTTP now recipHash (actbBL body) sig remotes
|
||||
Just forwardHttpAccept -> do
|
||||
forkWorker "topicAcceptF inbox-forwarding" forwardHttpAccept
|
||||
return "Sent a Grant and ran inbox-forwarding of the Accept"
|
||||
|
||||
where
|
||||
|
||||
insertGrantToOutbox
|
||||
:: Either (LocalActorBy Key) (FedURI, Maybe LocalURI)
|
||||
-> OutboxItemId
|
||||
-> ReaderT SqlBackend Handler
|
||||
( AP.Doc AP.Activity URIMode
|
||||
, RecipientRoutes
|
||||
, [(Host, NonEmpty LocalURI)]
|
||||
, [Host]
|
||||
)
|
||||
insertGrantToOutbox sender grantID = do
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
prepareGrant sender = do
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
hLocal <- asksSite siteInstanceHost
|
||||
|
||||
accepter <- getJust $ remoteAuthorId author
|
||||
let topicByHash = grantResourceLocalActor $ topicResource recipHash
|
||||
|
||||
senderHash <- bitraverse hashLocalActor pure sender
|
||||
grantHash <- encodeKeyHashid grantID
|
||||
|
||||
let audSender =
|
||||
case senderHash of
|
||||
|
|
@ -511,22 +459,19 @@ topicAcceptF topicActor topicResource deliverRemoteDB deliverRemoteHTTP now reci
|
|||
collectAudience [audSender, audRecip, audTopic]
|
||||
|
||||
recips = map encodeRouteHome audLocal ++ audRemote
|
||||
doc = AP.Doc hLocal AP.Activity
|
||||
{ AP.activityId = Just $ encodeRouteLocal $ activityRoute topicByHash grantHash
|
||||
, AP.activityActor = encodeRouteLocal $ renderLocalActor topicByHash
|
||||
, AP.activityCapability = Nothing
|
||||
, AP.activitySummary = Nothing
|
||||
, AP.activityAudience = AP.Audience recips [] [] [] [] []
|
||||
, AP.activityFulfills = [AP.acceptObject accept]
|
||||
, AP.activitySpecific = AP.GrantActivity AP.Grant
|
||||
{ AP.grantObject = Left AP.RoleAdmin
|
||||
, AP.grantContext = encodeRouteHome $ renderLocalActor topicByHash
|
||||
, AP.grantTarget = remoteAuthorURI author
|
||||
action = AP.Action
|
||||
{ AP.actionCapability = Nothing
|
||||
, AP.actionSummary = Nothing
|
||||
, AP.actionAudience = AP.Audience recips [] [] [] [] []
|
||||
, AP.actionFulfills = [AP.acceptObject accept]
|
||||
, AP.actionSpecific = AP.GrantActivity AP.Grant
|
||||
{ AP.grantObject = Left AP.RoleAdmin
|
||||
, AP.grantContext = encodeRouteHome $ renderLocalActor topicByHash
|
||||
, AP.grantTarget = remoteAuthorURI author
|
||||
}
|
||||
}
|
||||
|
||||
update grantID [OutboxItemActivity =. persistJSONObjectFromDoc doc]
|
||||
return (doc, recipientSet, remoteActors, fwdHosts)
|
||||
return (action, recipientSet, remoteActors, fwdHosts)
|
||||
|
||||
repoAcceptF
|
||||
:: UTCTime
|
||||
|
|
@ -537,8 +482,7 @@ repoAcceptF
|
|||
-> LocalURI
|
||||
-> AP.Accept URIMode
|
||||
-> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
|
||||
repoAcceptF =
|
||||
topicAcceptF repoActor GrantResourceRepo deliverRemoteDB_R deliverRemoteHTTP_R
|
||||
repoAcceptF = topicAcceptF repoActor GrantResourceRepo
|
||||
|
||||
deckAcceptF
|
||||
:: UTCTime
|
||||
|
|
@ -549,8 +493,7 @@ deckAcceptF
|
|||
-> LocalURI
|
||||
-> AP.Accept URIMode
|
||||
-> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
|
||||
deckAcceptF =
|
||||
topicAcceptF deckActor GrantResourceDeck deliverRemoteDB_D deliverRemoteHTTP_D
|
||||
deckAcceptF = topicAcceptF deckActor GrantResourceDeck
|
||||
|
||||
loomAcceptF
|
||||
:: UTCTime
|
||||
|
|
@ -561,8 +504,7 @@ loomAcceptF
|
|||
-> LocalURI
|
||||
-> AP.Accept URIMode
|
||||
-> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
|
||||
loomAcceptF =
|
||||
topicAcceptF loomActor GrantResourceLoom deliverRemoteDB_L deliverRemoteHTTP_L
|
||||
loomAcceptF = topicAcceptF loomActor GrantResourceLoom
|
||||
|
||||
personGrantF
|
||||
:: UTCTime
|
||||
|
|
@ -616,21 +558,16 @@ personGrantF now recipHash author body mfwd luGrant grant = (,Nothing) <$> do
|
|||
if targetIsRecip
|
||||
then makeRecipientSet [] [LocalStagePersonFollowers recipHash]
|
||||
else makeRecipientSet [] []
|
||||
remoteRecips <-
|
||||
insertRemoteActivityToLocalInboxes
|
||||
False grantID $
|
||||
localRecipSieve'
|
||||
sieve False False localRecips
|
||||
(sig,) <$> deliverRemoteDB_P (actbBL body) grantID personRecipID sig remoteRecips
|
||||
forwardActivityDB
|
||||
(actbBL body) localRecips sig (personActor personRecip)
|
||||
(LocalActorPerson recipHash) sieve grantID
|
||||
|
||||
-- Launch asynchronous HTTP forwarding of the Invite activity
|
||||
-- Launch asynchronous HTTP forwarding of the Grant activity
|
||||
case mhttp of
|
||||
Nothing -> return "I already have this activity in my inbox, doing nothing"
|
||||
Just mremotesHttpFwd -> do
|
||||
for_ mremotesHttpFwd $ \ (sig, remotes) ->
|
||||
forkWorker "personGrantF inbox-forwarding" $
|
||||
deliverRemoteHTTP_P now recipHash (actbBL body) sig remotes
|
||||
Just mhttpFwd -> do
|
||||
for_ mhttpFwd $ forkWorker "personGrantF inbox-forwarding"
|
||||
return $
|
||||
case mremotesHttpFwd of
|
||||
case mhttpFwd of
|
||||
Nothing -> "Inserted to inbox, no inbox-forwarding to do"
|
||||
Just _ -> "Inserted to inbox and ran inbox-forwarding of the Grant"
|
||||
|
|
|
|||
|
|
@ -344,7 +344,7 @@ followF
|
|||
iidAuthor = remoteAuthorInstance author
|
||||
hAuthor = objUriAuthority $ remoteAuthorURI author
|
||||
hostSection = ((iidAuthor, hAuthor), raInfo :| [])
|
||||
(obiid, doc,) <$> deliverRemoteDB'' [] obiid [] [hostSection]
|
||||
(obiid, doc,) <$> deliverRemoteDB [] obiid [] [hostSection]
|
||||
else do
|
||||
delete obiid
|
||||
return $ Left "You're already a follower of me"
|
||||
|
|
@ -698,7 +698,7 @@ sharerUndoF recipHash now author body mfwd luUndo (Undo uObj) = do
|
|||
obiidAccept
|
||||
localRecipsAccept
|
||||
(obiidAccept,docAccept,fwdHostsAccept,) <$>
|
||||
deliverRemoteDB'' fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept
|
||||
deliverRemoteDB fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept
|
||||
return (result, mremotesHttpFwd, mremotesHttpAccept)
|
||||
case mmmhttp of
|
||||
Nothing -> return "Activity already in my inbox"
|
||||
|
|
@ -802,7 +802,7 @@ projectUndoF recipHash now author body mfwd luUndo (Undo uObj) = do
|
|||
obiidAccept
|
||||
localRecipsAccept
|
||||
(obiidAccept,docAccept,fwdHostsAccept,) <$>
|
||||
deliverRemoteDB'' fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept
|
||||
deliverRemoteDB fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept
|
||||
return (result, mremotesHttpFwd, mremotesHttpAccept)
|
||||
case mmmhttp of
|
||||
Nothing -> return "Activity already in my inbox"
|
||||
|
|
@ -900,7 +900,7 @@ repoUndoF recipHash now author body mfwd luUndo (Undo uObj) = do
|
|||
obiidAccept
|
||||
localRecipsAccept
|
||||
(obiidAccept,docAccept,fwdHostsAccept,) <$>
|
||||
deliverRemoteDB'' fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept
|
||||
deliverRemoteDB fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept
|
||||
return (result, mremotesHttpFwd, mremotesHttpAccept)
|
||||
case mmmhttp of
|
||||
Nothing -> return "Activity already in my inbox"
|
||||
|
|
|
|||
|
|
@ -96,7 +96,7 @@ import Vervis.Cloth
|
|||
import Vervis.Data.Actor
|
||||
import Vervis.Data.Ticket
|
||||
import Vervis.Darcs
|
||||
import Vervis.Delivery
|
||||
import Vervis.Web.Delivery
|
||||
import Vervis.Federation.Auth
|
||||
import Vervis.Federation.Util
|
||||
import Vervis.FedURI
|
||||
|
|
@ -107,6 +107,7 @@ import Vervis.Model
|
|||
import Vervis.Model.Role
|
||||
import Vervis.Model.Ticket
|
||||
import Vervis.Path
|
||||
import Vervis.Persist.Actor
|
||||
import Vervis.Persist.Ticket
|
||||
import Vervis.Query
|
||||
import Vervis.Recipient
|
||||
|
|
@ -358,60 +359,48 @@ deckOfferTicketF now recipDeckHash author body mfwd luOffer ticket uTarget = do
|
|||
|
||||
-- Find recipient deck in DB, returning 404 if doesn't exist because we're
|
||||
-- in the deck's inbox post handler
|
||||
maybeHttp <- lift $ runDB $ do
|
||||
(recipDeckActorID, recipDeckActor) <- do
|
||||
maybeHttp <- runDBExcept $ do
|
||||
(recipDeckActorID, recipDeckActor) <- lift $ do
|
||||
deck <- get404 recipDeckID
|
||||
let actorID = deckActor deck
|
||||
(actorID,) <$> getJust actorID
|
||||
|
||||
-- Insert the Offer to deck's inbox
|
||||
mractid <- insertToInbox now author body (actorInbox recipDeckActor) luOffer False
|
||||
mractid <- lift $ insertToInbox now author body (actorInbox recipDeckActor) luOffer False
|
||||
for mractid $ \ offerID -> do
|
||||
|
||||
-- Forward the Offer activity to relevant local stages, and
|
||||
-- schedule delivery for unavailable remote members of them
|
||||
maybeHttpFwdOffer <- for mfwd $ \ (localRecips, sig) -> do
|
||||
maybeHttpFwdOffer <- lift $ for mfwd $ \ (localRecips, sig) -> do
|
||||
let sieve =
|
||||
makeRecipientSet
|
||||
[]
|
||||
[LocalStageDeckFollowers recipDeckHash]
|
||||
remoteRecips <-
|
||||
insertRemoteActivityToLocalInboxes False offerID $
|
||||
localRecipSieve' sieve False False localRecips
|
||||
remoteRecipsHttp <-
|
||||
deliverRemoteDB_D
|
||||
(actbBL body) offerID recipDeckID sig remoteRecips
|
||||
return $
|
||||
deliverRemoteHTTP_D
|
||||
now recipDeckHash (actbBL body) sig remoteRecipsHttp
|
||||
forwardActivityDB
|
||||
(actbBL body) localRecips sig recipDeckActorID
|
||||
(LocalActorDeck recipDeckHash) sieve offerID
|
||||
|
||||
-- Insert the new ticket to our DB
|
||||
acceptID <- insertEmptyOutboxItem (actorOutbox recipDeckActor) now
|
||||
taskID <- insertTask now title desc source recipDeckID offerID acceptID
|
||||
acceptID <- lift $ insertEmptyOutboxItem (actorOutbox recipDeckActor) now
|
||||
taskID <- lift $ insertTask now title desc source recipDeckID offerID acceptID
|
||||
|
||||
-- Prepare an Accept activity and insert to deck's outbox
|
||||
(docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
|
||||
insertAcceptToOutbox taskID acceptID
|
||||
(actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
|
||||
lift $ prepareAccept taskID
|
||||
_luAccept <- lift $ updateOutboxItem (LocalActorDeck recipDeckID) acceptID actionAccept
|
||||
|
||||
-- Deliver the Accept to local recipients, and schedule delivery
|
||||
-- for unavailable remote recipients
|
||||
knownRemoteRecipsAccept <-
|
||||
deliverLocal'
|
||||
False (LocalActorDeck recipDeckHash) recipDeckActorID
|
||||
acceptID localRecipsAccept
|
||||
remoteRecipsHttpAccept <-
|
||||
deliverRemoteDB''
|
||||
fwdHostsAccept acceptID remoteRecipsAccept
|
||||
knownRemoteRecipsAccept
|
||||
deliverHttpAccept <-
|
||||
deliverActivityDB
|
||||
(LocalActorDeck recipDeckHash) recipDeckActorID
|
||||
localRecipsAccept remoteRecipsAccept fwdHostsAccept
|
||||
acceptID actionAccept
|
||||
|
||||
-- Return instructions for HTTP inbox-forwarding of the Offer
|
||||
-- activity, and for HTTP delivery of the Accept activity to
|
||||
-- remote recipients
|
||||
return
|
||||
( maybeHttpFwdOffer
|
||||
, deliverRemoteHttp'
|
||||
fwdHostsAccept acceptID docAccept remoteRecipsHttpAccept
|
||||
)
|
||||
return (maybeHttpFwdOffer, deliverHttpAccept)
|
||||
|
||||
-- Launch asynchronous HTTP forwarding of the Offer activity and HTTP
|
||||
-- delivery of the Accept activity
|
||||
|
|
@ -448,22 +437,11 @@ deckOfferTicketF now recipDeckHash author body mfwd luOffer ticket uTarget = do
|
|||
}
|
||||
insert $ TicketDeck tid deckID
|
||||
|
||||
insertAcceptToOutbox
|
||||
:: TicketDeckId
|
||||
-> OutboxItemId
|
||||
-> ReaderT SqlBackend Handler
|
||||
( AP.Doc AP.Activity URIMode
|
||||
, RecipientRoutes
|
||||
, [(Host, NonEmpty LocalURI)]
|
||||
, [Host]
|
||||
)
|
||||
insertAcceptToOutbox taskID acceptID = do
|
||||
prepareAccept taskID = do
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
hLocal <- asksSite siteInstanceHost
|
||||
|
||||
taskHash <- encodeKeyHashid taskID
|
||||
acceptHash <- encodeKeyHashid acceptID
|
||||
|
||||
ra <- getJust $ remoteAuthorId author
|
||||
|
||||
|
|
@ -479,26 +457,20 @@ deckOfferTicketF now recipDeckHash author body mfwd luOffer ticket uTarget = do
|
|||
collectAudience [audSender, audTracker]
|
||||
|
||||
recips = map encodeRouteHome audLocal ++ audRemote
|
||||
doc = AP.Doc hLocal AP.Activity
|
||||
{ AP.activityId =
|
||||
Just $ encodeRouteLocal $
|
||||
DeckOutboxItemR recipDeckHash acceptHash
|
||||
, AP.activityActor =
|
||||
encodeRouteLocal $ DeckR recipDeckHash
|
||||
, AP.activityCapability = Nothing
|
||||
, AP.activitySummary = Nothing
|
||||
, AP.activityAudience = AP.Audience recips [] [] [] [] []
|
||||
, AP.activityFulfills = []
|
||||
, AP.activitySpecific = AP.AcceptActivity AP.Accept
|
||||
{ acceptObject = ObjURI hAuthor luOffer
|
||||
, acceptResult =
|
||||
action = AP.Action
|
||||
{ AP.actionCapability = Nothing
|
||||
, AP.actionSummary = Nothing
|
||||
, AP.actionAudience = AP.Audience recips [] [] [] [] []
|
||||
, AP.actionFulfills = []
|
||||
, AP.actionSpecific = AP.AcceptActivity AP.Accept
|
||||
{ AP.acceptObject = ObjURI hAuthor luOffer
|
||||
, AP.acceptResult =
|
||||
Just $ encodeRouteLocal $
|
||||
TicketR recipDeckHash taskHash
|
||||
}
|
||||
}
|
||||
|
||||
update acceptID [OutboxItemActivity =. persistJSONObjectFromDoc doc]
|
||||
return (doc, recipientSet, remoteActors, fwdHosts)
|
||||
return (action, recipientSet, remoteActors, fwdHosts)
|
||||
|
||||
activityAlreadyInInbox hAct luAct inboxID = fmap isJust . runMaybeT $ do
|
||||
instanceID <- MaybeT $ getKeyBy $ UniqueInstance hAct
|
||||
|
|
@ -684,33 +656,28 @@ loomOfferTicketF now recipLoomHash author body mfwd luOffer ticket uTarget = do
|
|||
return $ Right uClone
|
||||
return $ Right $ maybeOriginRepo
|
||||
|
||||
maybeHttp <- lift $ runSiteDB $ do
|
||||
maybeHttp <- runSiteDBExcept $ do
|
||||
|
||||
-- Insert the Offer to loom's inbox
|
||||
mractid <- insertToInbox now author body (actorInbox recipLoomActor) luOffer False
|
||||
mractid <- lift $ insertToInbox now author body (actorInbox recipLoomActor) luOffer False
|
||||
for mractid $ \ offerID -> do
|
||||
|
||||
-- Forward the Offer activity to relevant local stages, and
|
||||
-- schedule delivery for unavailable remote members of them
|
||||
maybeHttpFwdOffer <- for mfwd $ \ (localRecips, sig) -> do
|
||||
maybeHttpFwdOffer <- lift $ for mfwd $ \ (localRecips, sig) -> do
|
||||
let sieve =
|
||||
makeRecipientSet
|
||||
[]
|
||||
[LocalStageLoomFollowers recipLoomHash]
|
||||
remoteRecips <-
|
||||
insertRemoteActivityToLocalInboxes False offerID $
|
||||
localRecipSieve' sieve False False localRecips
|
||||
remoteRecipsHttp <-
|
||||
deliverRemoteDB_L
|
||||
(actbBL body) offerID recipLoomID sig remoteRecips
|
||||
return $
|
||||
deliverRemoteHTTP_L
|
||||
now recipLoomHash (actbBL body) sig remoteRecipsHttp
|
||||
forwardActivityDB
|
||||
(actbBL body) localRecips sig
|
||||
recipLoomActorID (LocalActorLoom recipLoomHash)
|
||||
sieve offerID
|
||||
|
||||
-- Insert the new ticket to our DB
|
||||
acceptID <- insertEmptyOutboxItem (actorOutbox recipLoomActor) now
|
||||
ticketID <- insertTicket now title desc source offerID acceptID
|
||||
clothID <- insertMerge recipLoomID ticketID maybeTargetBranch originOrBundle'
|
||||
acceptID <- lift $ insertEmptyOutboxItem (actorOutbox recipLoomActor) now
|
||||
ticketID <- lift $ insertTicket now title desc source offerID acceptID
|
||||
clothID <- lift $ insertMerge recipLoomID ticketID maybeTargetBranch originOrBundle'
|
||||
let maybePull =
|
||||
let maybeTipInfo =
|
||||
case tipInfo of
|
||||
|
|
@ -720,30 +687,24 @@ loomOfferTicketF now recipLoomHash author body mfwd luOffer ticket uTarget = do
|
|||
in (clothID, targetRepoID, hasBundle,) <$> maybeTipInfo
|
||||
|
||||
-- Prepare an Accept activity and insert to loom's outbox
|
||||
(docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
|
||||
insertAcceptToOutbox clothID acceptID
|
||||
(actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
|
||||
lift $ prepareAccept clothID
|
||||
_luAccept <- lift $ updateOutboxItem (LocalActorLoom recipLoomID) acceptID actionAccept
|
||||
|
||||
-- Deliver the Accept to local recipients, and schedule delivery
|
||||
-- for unavailable remote recipients
|
||||
knownRemoteRecipsAccept <-
|
||||
deliverLocal'
|
||||
False (LocalActorLoom recipLoomHash) recipLoomActorID
|
||||
acceptID localRecipsAccept
|
||||
remoteRecipsHttpAccept <-
|
||||
deliverRemoteDB''
|
||||
fwdHostsAccept acceptID remoteRecipsAccept
|
||||
knownRemoteRecipsAccept
|
||||
deliverHttpAccept <-
|
||||
deliverActivityDB
|
||||
(LocalActorLoom recipLoomHash) recipLoomActorID
|
||||
localRecipsAccept remoteRecipsAccept
|
||||
fwdHostsAccept acceptID actionAccept
|
||||
|
||||
-- Return instructions for HTTP inbox-forwarding of the Offer
|
||||
-- activity, and for HTTP delivery of the Accept activity to
|
||||
-- remote recipients, and for generating patches from
|
||||
-- the origin repo
|
||||
return
|
||||
( maybeHttpFwdOffer
|
||||
, deliverRemoteHttp'
|
||||
fwdHostsAccept acceptID docAccept remoteRecipsHttpAccept
|
||||
, maybePull
|
||||
)
|
||||
(maybeHttpFwdOffer, deliverHttpAccept, maybePull)
|
||||
|
||||
-- Launch asynchronous HTTP forwarding of the Offer activity and HTTP
|
||||
-- delivery of the Accept activity, and generate patches if we opened
|
||||
|
|
@ -811,22 +772,11 @@ loomOfferTicketF now recipLoomHash author body mfwd luOffer ticket uTarget = do
|
|||
NE.map (Patch bundleID now typ) diffs
|
||||
return clothID
|
||||
|
||||
insertAcceptToOutbox
|
||||
:: TicketLoomId
|
||||
-> OutboxItemId
|
||||
-> WorkerDB
|
||||
( AP.Doc AP.Activity URIMode
|
||||
, RecipientRoutes
|
||||
, [(Host, NonEmpty LocalURI)]
|
||||
, [Host]
|
||||
)
|
||||
insertAcceptToOutbox clothID acceptID = do
|
||||
prepareAccept clothID = do
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
hLocal <- asksSite siteInstanceHost
|
||||
|
||||
clothHash <- encodeKeyHashid clothID
|
||||
acceptHash <- encodeKeyHashid acceptID
|
||||
|
||||
ra <- getJust $ remoteAuthorId author
|
||||
|
||||
|
|
@ -842,26 +792,20 @@ loomOfferTicketF now recipLoomHash author body mfwd luOffer ticket uTarget = do
|
|||
collectAudience [audSender, audTracker]
|
||||
|
||||
recips = map encodeRouteHome audLocal ++ audRemote
|
||||
doc = AP.Doc hLocal AP.Activity
|
||||
{ AP.activityId =
|
||||
Just $ encodeRouteLocal $
|
||||
LoomOutboxItemR recipLoomHash acceptHash
|
||||
, AP.activityActor =
|
||||
encodeRouteLocal $ LoomR recipLoomHash
|
||||
, AP.activityCapability = Nothing
|
||||
, AP.activitySummary = Nothing
|
||||
, AP.activityAudience = AP.Audience recips [] [] [] [] []
|
||||
, AP.activityFulfills = []
|
||||
, AP.activitySpecific = AP.AcceptActivity AP.Accept
|
||||
{ acceptObject = ObjURI hAuthor luOffer
|
||||
, acceptResult =
|
||||
action = AP.Action
|
||||
{ AP.actionCapability = Nothing
|
||||
, AP.actionSummary = Nothing
|
||||
, AP.actionAudience = AP.Audience recips [] [] [] [] []
|
||||
, AP.actionFulfills = []
|
||||
, AP.actionSpecific = AP.AcceptActivity AP.Accept
|
||||
{ AP.acceptObject = ObjURI hAuthor luOffer
|
||||
, AP.acceptResult =
|
||||
Just $ encodeRouteLocal $
|
||||
ClothR recipLoomHash clothHash
|
||||
}
|
||||
}
|
||||
|
||||
update acceptID [OutboxItemActivity =. persistJSONObjectFromDoc doc]
|
||||
return (doc, recipientSet, remoteActors, fwdHosts)
|
||||
return (action, recipientSet, remoteActors, fwdHosts)
|
||||
|
||||
repoOfferTicketF
|
||||
:: UTCTime
|
||||
|
|
@ -918,7 +862,7 @@ repoOfferTicketF now recipHash author body mfwd luOffer ticket uTarget = do
|
|||
obiidAccept
|
||||
localRecipsAccept
|
||||
(obiidAccept,docAccept,fwdHostsAccept,) <$>
|
||||
deliverRemoteDB'' fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept
|
||||
deliverRemoteDB fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept
|
||||
return (mremotesHttpFwd, obiidAccept, docAccept, fwdHostsAccept, recipsAccept)
|
||||
case mmhttp of
|
||||
Nothing -> return "Offer target isn't me, not using"
|
||||
|
|
@ -1085,7 +1029,7 @@ repoAddBundleF now recipHash author body mfwd luAdd patches uTarget = do
|
|||
obiidAccept
|
||||
localRecipsAccept
|
||||
(obiidAccept,docAccept,fwdHostsAccept,) <$>
|
||||
deliverRemoteDB'' fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept
|
||||
deliverRemoteDB fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept
|
||||
return (mremotesHttpFwd, mremotesHttpAccept)
|
||||
case mhttp of
|
||||
Nothing -> return "I already have this activity in my inbox, doing nothing"
|
||||
|
|
@ -1242,15 +1186,15 @@ loomApplyF now recipLoomHash author body mfwd luApply apply = (,Nothing) <$> do
|
|||
-- Apply patches
|
||||
applyPatches repoID maybeBranch diffs
|
||||
|
||||
maybeHttp <- lift $ runDB $ do
|
||||
maybeHttp <- runDBExcept $ do
|
||||
|
||||
-- Insert the Apply to loom's inbox
|
||||
mractid <- insertToInbox now author body (actorInbox recipLoomActor) luApply False
|
||||
mractid <- lift $ insertToInbox now author body (actorInbox recipLoomActor) luApply False
|
||||
for mractid $ \ applyID -> do
|
||||
|
||||
-- Forward the Apply activity to relevant local stages, and
|
||||
-- schedule delivery for unavailable remote members of them
|
||||
maybeHttpFwdApply <- for mfwd $ \ (localRecips, sig) -> do
|
||||
maybeHttpFwdApply <- lift $ for mfwd $ \ (localRecips, sig) -> do
|
||||
clothHash <- encodeKeyHashid clothID
|
||||
let sieve =
|
||||
makeRecipientSet
|
||||
|
|
@ -1258,44 +1202,32 @@ loomApplyF now recipLoomHash author body mfwd luApply apply = (,Nothing) <$> do
|
|||
[ LocalStageLoomFollowers recipLoomHash
|
||||
, LocalStageClothFollowers recipLoomHash clothHash
|
||||
]
|
||||
remoteRecips <-
|
||||
insertRemoteActivityToLocalInboxes False applyID $
|
||||
localRecipSieve' sieve False False localRecips
|
||||
remoteRecipsHttp <-
|
||||
deliverRemoteDB_L
|
||||
(actbBL body) applyID recipLoomID sig remoteRecips
|
||||
return $
|
||||
deliverRemoteHTTP_L
|
||||
now recipLoomHash (actbBL body) sig remoteRecipsHttp
|
||||
forwardActivityDB
|
||||
(actbBL body) localRecips sig recipLoomActorID
|
||||
(LocalActorLoom recipLoomHash) sieve applyID
|
||||
|
||||
-- Mark ticket in DB as resolved by the Apply
|
||||
acceptID <-
|
||||
insertEmptyOutboxItem (actorOutbox recipLoomActor) now
|
||||
insertResolve ticketID applyID acceptID
|
||||
lift $ insertEmptyOutboxItem (actorOutbox recipLoomActor) now
|
||||
lift $ insertResolve ticketID applyID acceptID
|
||||
|
||||
-- Prepare an Accept activity and insert to loom's outbox
|
||||
(docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
|
||||
insertAcceptToOutbox uCap clothID acceptID
|
||||
(actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
|
||||
lift $ prepareAccept clothID
|
||||
_luAccept <- lift $ updateOutboxItem (LocalActorLoom recipLoomID) acceptID actionAccept
|
||||
|
||||
-- Deliver the Accept to local recipients, and schedule delivery
|
||||
-- for unavailable remote recipients
|
||||
knownRemoteRecipsAccept <-
|
||||
deliverLocal'
|
||||
False (LocalActorLoom recipLoomHash) recipLoomActorID
|
||||
acceptID localRecipsAccept
|
||||
remoteRecipsHttpAccept <-
|
||||
deliverRemoteDB''
|
||||
fwdHostsAccept acceptID remoteRecipsAccept
|
||||
knownRemoteRecipsAccept
|
||||
deliverHttpAccept <-
|
||||
deliverActivityDB
|
||||
(LocalActorLoom recipLoomHash) recipLoomActorID
|
||||
localRecipsAccept remoteRecipsAccept fwdHostsAccept
|
||||
acceptID actionAccept
|
||||
|
||||
-- Return instructions for HTTP inbox-forwarding of the Apply
|
||||
-- activity, and for HTTP delivery of the Accept activity to
|
||||
-- remote recipients
|
||||
return
|
||||
( maybeHttpFwdApply
|
||||
, deliverRemoteHttp'
|
||||
fwdHostsAccept acceptID docAccept remoteRecipsHttpAccept
|
||||
)
|
||||
return (maybeHttpFwdApply, deliverHttpAccept)
|
||||
|
||||
-- Launch asynchronous HTTP forwarding of the Apply activity and HTTP
|
||||
-- delivery of the Accept activity
|
||||
|
|
@ -1326,13 +1258,10 @@ loomApplyF now recipLoomHash author body mfwd luApply apply = (,Nothing) <$> do
|
|||
}
|
||||
update ticketID [TicketStatus =. TSClosed]
|
||||
|
||||
insertAcceptToOutbox uCap clothID acceptID = do
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
prepareAccept clothID = do
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
hLocal <- asksSite siteInstanceHost
|
||||
|
||||
clothHash <- encodeKeyHashid clothID
|
||||
acceptHash <- encodeKeyHashid acceptID
|
||||
|
||||
ra <- getJust $ remoteAuthorId author
|
||||
|
||||
|
|
@ -1353,24 +1282,18 @@ loomApplyF now recipLoomHash author body mfwd luApply apply = (,Nothing) <$> do
|
|||
collectAudience [audSender, audTracker]
|
||||
|
||||
recips = map encodeRouteHome audLocal ++ audRemote
|
||||
doc = AP.Doc hLocal AP.Activity
|
||||
{ AP.activityId =
|
||||
Just $ encodeRouteLocal $
|
||||
LoomOutboxItemR recipLoomHash acceptHash
|
||||
, AP.activityActor =
|
||||
encodeRouteLocal $ LoomR recipLoomHash
|
||||
, AP.activityCapability = Just uCap
|
||||
, AP.activitySummary = Nothing
|
||||
, AP.activityAudience = AP.Audience recips [] [] [] [] []
|
||||
, AP.activityFulfills = []
|
||||
, AP.activitySpecific = AP.AcceptActivity AP.Accept
|
||||
{ acceptObject = ObjURI hAuthor luApply
|
||||
, acceptResult = Nothing
|
||||
action = AP.Action
|
||||
{ AP.actionCapability = Nothing
|
||||
, AP.actionSummary = Nothing
|
||||
, AP.actionAudience = AP.Audience recips [] [] [] [] []
|
||||
, AP.actionFulfills = []
|
||||
, AP.actionSpecific = AP.AcceptActivity AP.Accept
|
||||
{ AP.acceptObject = ObjURI hAuthor luApply
|
||||
, AP.acceptResult = Nothing
|
||||
}
|
||||
}
|
||||
|
||||
update acceptID [OutboxItemActivity =. persistJSONObjectFromDoc doc]
|
||||
return (doc, recipientSet, remoteActors, fwdHosts)
|
||||
return (action, recipientSet, remoteActors, fwdHosts)
|
||||
|
||||
personOfferDepF
|
||||
:: UTCTime
|
||||
|
|
@ -1430,7 +1353,7 @@ personOfferDepF now recipHash author body mfwd luOffer dep uTarget = do
|
|||
(personInbox personRecip)
|
||||
obiidAccept
|
||||
localRecipsAccept
|
||||
(obiidAccept,docAccept,fwdHostsAccept,) <$> deliverRemoteDB'' fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept
|
||||
(obiidAccept,docAccept,fwdHostsAccept,) <$> deliverRemoteDB fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept
|
||||
return (mremotesHttpFwd, mremotesHttpAccept)
|
||||
case mhttp of
|
||||
Nothing -> return "I already have this activity in my inbox, doing nothing"
|
||||
|
|
@ -1642,7 +1565,7 @@ deckOfferDepF now recipHash author body mfwd luOffer dep uTarget = do
|
|||
(actorInbox actorRecip)
|
||||
obiidAccept
|
||||
localRecipsAccept
|
||||
(obiidAccept,docAccept,fwdHostsAccept,) <$> deliverRemoteDB'' fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept
|
||||
(obiidAccept,docAccept,fwdHostsAccept,) <$> deliverRemoteDB fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept
|
||||
return (mremotesHttpFwd, mremotesHttpAccept)
|
||||
case mhttp of
|
||||
Nothing -> return "I already have this activity in my inbox, doing nothing"
|
||||
|
|
@ -1810,7 +1733,7 @@ repoOfferDepF now recipHash author body mfwd luOffer dep uTarget = do
|
|||
(repoInbox repoRecip)
|
||||
obiidAccept
|
||||
localRecipsAccept
|
||||
(obiidAccept,docAccept,fwdHostsAccept,) <$> deliverRemoteDB'' fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept
|
||||
(obiidAccept,docAccept,fwdHostsAccept,) <$> deliverRemoteDB fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept
|
||||
return (mremotesHttpFwd, mremotesHttpAccept)
|
||||
case mhttp of
|
||||
Nothing -> return "I already have this activity in my inbox, doing nothing"
|
||||
|
|
@ -2007,7 +1930,7 @@ deckResolveF now recipHash author body mfwd luResolve (Resolve uObject) = do
|
|||
obiidAccept
|
||||
localRecipsAccept
|
||||
(mremotesHttpFwd,obiidAccept,docAccept,fwdHostsAccept,) <$>
|
||||
deliverRemoteDB'' fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept
|
||||
deliverRemoteDB fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept
|
||||
case mmmmhttp of
|
||||
Nothing -> return "I already have this activity in my inbox, doing nothing"
|
||||
Just mmmhttp ->
|
||||
|
|
@ -2144,7 +2067,7 @@ repoResolveF now recipHash author body mfwd luResolve (Resolve uObject) = do
|
|||
obiidAccept
|
||||
localRecipsAccept
|
||||
(mremotesHttpFwd,obiidAccept,docAccept,fwdHostsAccept,) <$>
|
||||
deliverRemoteDB'' fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept
|
||||
deliverRemoteDB fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept
|
||||
case mmmmhttp of
|
||||
Nothing -> return "I already have this activity in my inbox, doing nothing"
|
||||
Just mmmhttp ->
|
||||
|
|
|
|||
|
|
@ -86,7 +86,7 @@ import Vervis.Cloth
|
|||
import Vervis.Data.Actor
|
||||
import Vervis.Data.Collab
|
||||
import Vervis.Data.Ticket
|
||||
import Vervis.Delivery
|
||||
import Vervis.Web.Delivery
|
||||
import Vervis.FedURI
|
||||
import Vervis.Foundation
|
||||
import Vervis.Model
|
||||
|
|
|
|||
|
|
@ -69,6 +69,7 @@ import Yesod.Mail.Send
|
|||
|
||||
import qualified Network.HTTP.Signature as S (Algorithm (..))
|
||||
|
||||
import Crypto.ActorKey
|
||||
import Crypto.PublicVerifKey
|
||||
import Network.FedURI
|
||||
import Web.ActivityAccess
|
||||
|
|
@ -83,7 +84,6 @@ import Text.Email.Local
|
|||
import Text.Jasmine.Local (discardm)
|
||||
import Yesod.Paginate.Local
|
||||
|
||||
import Vervis.ActorKey
|
||||
import Vervis.FedURI
|
||||
import Vervis.Hook
|
||||
import Vervis.Model
|
||||
|
|
@ -114,7 +114,7 @@ data App = App
|
|||
, appLogger :: Logger
|
||||
, appMailQueue :: Maybe (Chan (MailRecipe App))
|
||||
, appSvgFont :: PreparedFont Double
|
||||
, appActorKeys :: TVar (ActorKey, ActorKey, Bool)
|
||||
, appActorKeys :: Maybe (TVar (ActorKey, ActorKey, Bool))
|
||||
, appInstanceMutex :: InstanceMutex
|
||||
, appCapSignKey :: AccessTokenSecretKey
|
||||
, appHashidsContext :: HashidsContext
|
||||
|
|
@ -140,6 +140,7 @@ type DeckKeyHashid = KeyHashid Deck
|
|||
type LoomKeyHashid = KeyHashid Loom
|
||||
type TicketDeckKeyHashid = KeyHashid TicketDeck
|
||||
type TicketLoomKeyHashid = KeyHashid TicketLoom
|
||||
type SigKeyKeyHashid = KeyHashid SigKey
|
||||
|
||||
-- This is where we define all of the routes in our application. For a full
|
||||
-- explanation of the syntax, please see:
|
||||
|
|
@ -783,6 +784,7 @@ instance YesodActivityPub App where
|
|||
siteInstanceHost = appInstanceHost . appSettings
|
||||
sitePostSignedHeaders _ =
|
||||
hRequestTarget :| [hHost, hDate, hDigest, AP.hActivityPubActor]
|
||||
{-
|
||||
siteGetHttpSign = do
|
||||
(akey1, akey2, new1) <- liftIO . readTVarIO =<< asksSite appActorKeys
|
||||
renderUrl <- askUrlRender
|
||||
|
|
@ -791,6 +793,7 @@ instance YesodActivityPub App where
|
|||
then (renderUrl ActorKey1R, akey1)
|
||||
else (renderUrl ActorKey2R, akey2)
|
||||
return (KeyId $ encodeUtf8 keyID, actorKeySign akey)
|
||||
-}
|
||||
|
||||
instance YesodPaginate App where
|
||||
sitePageParamName _ = "page"
|
||||
|
|
@ -837,12 +840,16 @@ instance YesodBreadcrumbs App where
|
|||
|
||||
ReplyR _ -> ("", Nothing)
|
||||
|
||||
PersonStampR p k -> ("Stamp #" <> keyHashidText k, Just $ PersonR p)
|
||||
|
||||
GroupR g -> ("Team &" <> keyHashidText g, Just HomeR)
|
||||
GroupInboxR g -> ("Inbox", Just $ GroupR g)
|
||||
GroupOutboxR g -> ("Outbox", Just $ GroupR g)
|
||||
GroupOutboxItemR g i -> (keyHashidText i, Just $ GroupOutboxR g)
|
||||
GroupFollowersR g -> ("Followers", Just $ GroupR g)
|
||||
|
||||
GroupStampR g k -> ("Stamp #" <> keyHashidText k, Just $ GroupR g)
|
||||
|
||||
RepoR r -> ("Repo ^" <> keyHashidText r, Just HomeR)
|
||||
RepoInboxR r -> ("Inbox", Just $ RepoR r)
|
||||
RepoOutboxR r -> ("Outbox", Just $ RepoR r)
|
||||
|
|
@ -871,6 +878,8 @@ instance YesodBreadcrumbs App where
|
|||
|
||||
RepoLinkR _ _ -> ("", Nothing)
|
||||
|
||||
RepoStampR r k -> ("Stamp #" <> keyHashidText k, Just $ RepoR r)
|
||||
|
||||
DeckR d -> ("Ticket Tracker =" <> keyHashidText d, Just HomeR)
|
||||
DeckInboxR d -> ("Inbox", Just $ DeckR d)
|
||||
DeckOutboxR d -> ("Outbox", Just $ DeckR d)
|
||||
|
|
@ -886,6 +895,8 @@ instance YesodBreadcrumbs App where
|
|||
DeckFollowR _ -> ("", Nothing)
|
||||
DeckUnfollowR _ -> ("", Nothing)
|
||||
|
||||
DeckStampR d k -> ("Stamp #" <> keyHashidText k, Just $ DeckR d)
|
||||
|
||||
TicketR d t -> ("#" <> keyHashidText t, Just $ DeckTicketsR d)
|
||||
TicketDiscussionR d t -> ("Discussion", Just $ TicketR d t)
|
||||
TicketEventsR d t -> ("Events", Just $ TicketR d t)
|
||||
|
|
@ -910,6 +921,8 @@ instance YesodBreadcrumbs App where
|
|||
LoomFollowR _ -> ("", Nothing)
|
||||
LoomUnfollowR _ -> ("", Nothing)
|
||||
|
||||
LoomStampR l k -> ("Stamp #" <> keyHashidText k, Just $ LoomR l)
|
||||
|
||||
ClothR l c -> ("#" <> keyHashidText c, Just $ LoomClothsR l)
|
||||
ClothDiscussionR l c -> ("Discussion", Just $ ClothR l c)
|
||||
ClothEventsR l c -> ("Events", Just $ ClothR l c)
|
||||
|
|
|
|||
|
|
@ -37,43 +37,32 @@ where
|
|||
|
||||
import Control.Applicative
|
||||
import Control.Concurrent.STM.TVar
|
||||
import Control.Exception hiding (Handler)
|
||||
import Control.Monad
|
||||
import Control.Monad.Trans.Except
|
||||
import Data.Bitraversable
|
||||
import Data.List
|
||||
import Data.Maybe
|
||||
import Data.Text (Text)
|
||||
import Data.Time.Clock
|
||||
import Data.Traversable
|
||||
import Database.Persist
|
||||
import Text.Blaze.Html (preEscapedToHtml)
|
||||
import Text.Blaze.Html.Renderer.Text
|
||||
import Text.HTML.SanitizeXSS
|
||||
import Yesod.Auth
|
||||
import Yesod.Auth.Account
|
||||
import Yesod.Auth.Account.Message
|
||||
import Yesod.Core
|
||||
import Yesod.Core.Widget
|
||||
import Yesod.Form
|
||||
import Yesod.Persist.Core
|
||||
|
||||
import qualified Data.ByteString.Char8 as BC
|
||||
import qualified Data.HashMap.Strict as M
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Encoding as TE
|
||||
import qualified Data.Text.Lazy as TL
|
||||
import qualified Data.Text.Lazy.Encoding as TLE
|
||||
import qualified Database.Esqueleto as E
|
||||
|
||||
import Dvara
|
||||
|
||||
import Database.Persist.JSON
|
||||
import Network.FedURI
|
||||
import Web.Text
|
||||
import Yesod.ActivityPub
|
||||
import Yesod.Auth.Unverified
|
||||
import Yesod.FedURI
|
||||
import Yesod.Hashids
|
||||
import Yesod.MonadSite
|
||||
import Yesod.RenderSource
|
||||
|
|
@ -83,26 +72,19 @@ import qualified Web.ActivityPub as AP
|
|||
import Control.Monad.Trans.Except.Local
|
||||
import Data.Either.Local
|
||||
import Data.EventTime.Local
|
||||
import Data.Time.Clock.Local
|
||||
import Database.Persist.Local
|
||||
import Yesod.Form.Local
|
||||
import Yesod.Persist.Local
|
||||
|
||||
import Vervis.ActivityPub
|
||||
import Vervis.ActorKey
|
||||
import Vervis.API
|
||||
import Vervis.Client
|
||||
import Vervis.Data.Actor
|
||||
import Vervis.FedURI
|
||||
import Vervis.Foundation
|
||||
import Vervis.Model
|
||||
import Vervis.Model.Ident
|
||||
import Development.PatchMediaType
|
||||
import Vervis.Path
|
||||
import Vervis.Recipient
|
||||
import Vervis.Settings
|
||||
import Vervis.Ticket
|
||||
|
||||
import qualified Vervis.Darcs as D
|
||||
import qualified Vervis.Git as G
|
||||
import Vervis.Web.Actor
|
||||
|
||||
-- | Account verification email resend form
|
||||
getResendVerifyEmailR :: Handler Html
|
||||
|
|
@ -115,28 +97,11 @@ getResendVerifyEmailR = do
|
|||
^{resendVerifyEmailWidget (username person) AuthR}
|
||||
|]
|
||||
|
||||
getActorKey
|
||||
:: ((ActorKey, ActorKey, Bool) -> ActorKey)
|
||||
-> Route App
|
||||
-> Handler TypedContent
|
||||
getActorKey choose route = do
|
||||
actorKey <-
|
||||
liftIO . fmap (actorKeyPublicBin . choose) . readTVarIO =<<
|
||||
getsYesod appActorKeys
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
let key = AP.PublicKey
|
||||
{ AP.publicKeyId = LocalRefURI $ Left $ encodeRouteLocal route
|
||||
, AP.publicKeyExpires = Nothing
|
||||
, AP.publicKeyOwner = AP.OwnerInstance
|
||||
, AP.publicKeyMaterial = actorKey
|
||||
}
|
||||
provideHtmlAndAP key $ redirectToPrettyJSON route
|
||||
|
||||
getActorKey1R :: Handler TypedContent
|
||||
getActorKey1R = getActorKey (\ (k1, _, _) -> k1) ActorKey1R
|
||||
getActorKey1R = serveInstanceKey fst ActorKey1R
|
||||
|
||||
getActorKey2R :: Handler TypedContent
|
||||
getActorKey2R = getActorKey (\ (_, k2, _) -> k2) ActorKey2R
|
||||
getActorKey2R = serveInstanceKey snd ActorKey2R
|
||||
|
||||
getHomeR :: Handler Html
|
||||
getHomeR = do
|
||||
|
|
@ -1063,6 +1028,18 @@ fedUriField = Field
|
|||
, fieldEnctype = UrlEncoded
|
||||
}
|
||||
|
||||
capField
|
||||
:: Field Handler
|
||||
( FedURI
|
||||
, Either
|
||||
(LocalActorBy Key, LocalActorBy KeyHashid, OutboxItemId)
|
||||
FedURI
|
||||
)
|
||||
capField = checkMMap toCap fst fedUriField
|
||||
where
|
||||
toCap u =
|
||||
runExceptT $ (u,) <$> nameExceptT "Capability URI" (parseActivityURI u)
|
||||
|
||||
getSender :: Handler (Entity Person, Actor)
|
||||
getSender = do
|
||||
ep@(Entity _ p) <- requireAuth
|
||||
|
|
@ -1153,7 +1130,9 @@ postPublishOfferMergeR = do
|
|||
senderHash omgTitle omgDesc omgTracker
|
||||
omgTargetRepo (Just omgTargetBranch)
|
||||
omgOriginRepo (Just omgOriginBranch)
|
||||
offerID <- offerTicketC ep a summary audience ticket omgTracker
|
||||
(localRecips, remoteRecips, fwdHosts, action) <-
|
||||
makeServerInput Nothing summary audience $ AP.OfferActivity $ AP.Offer (AP.OfferTicket ticket) omgTracker
|
||||
offerID <- offerTicketC ep a Nothing localRecips remoteRecips fwdHosts action ticket omgTracker
|
||||
if trackerLocal
|
||||
then nameExceptT "Offer published but" $ runDBExcept $ do
|
||||
ticketID <- do
|
||||
|
|
@ -1175,10 +1154,9 @@ postPublishOfferMergeR = do
|
|||
else setMessage "Offer published"
|
||||
redirect dest
|
||||
|
||||
mergeForm :: Form (FedURI, FedURI)
|
||||
mergeForm = renderDivs $ (,)
|
||||
<$> areq fedUriField "Patch bundle to apply" Nothing
|
||||
<*> areq fedUriField "Grant activity to use for authorization" Nothing
|
||||
<*> areq capField "Grant activity to use for authorization" Nothing
|
||||
|
||||
getPublishMergeR :: Handler Html
|
||||
getPublishMergeR = do
|
||||
|
|
@ -1196,14 +1174,16 @@ postPublishMergeR = do
|
|||
federation <- getsYesod $ appFederation . appSettings
|
||||
unless federation badMethod
|
||||
|
||||
(uBundle, uCap) <- runFormPostRedirect PublishMergeR mergeForm
|
||||
(uBundle, (uCap, cap)) <- runFormPostRedirect PublishMergeR mergeForm
|
||||
|
||||
(ep@(Entity pid _), a) <- getSender
|
||||
senderHash <- encodeKeyHashid pid
|
||||
|
||||
result <- runExceptT $ do
|
||||
(maybeSummary, audience, apply) <- applyPatches senderHash uBundle
|
||||
applyC ep a (Just uCap) maybeSummary audience apply
|
||||
(localRecips, remoteRecips, fwdHosts, action) <-
|
||||
makeServerInput (Just uCap) maybeSummary audience (AP.ApplyActivity apply)
|
||||
applyC ep a (Just cap) localRecips remoteRecips fwdHosts action apply
|
||||
|
||||
case result of
|
||||
Left err -> do
|
||||
|
|
|
|||
|
|
@ -622,7 +622,7 @@ postClothApplyR :: KeyHashid Loom -> KeyHashid TicketLoom -> Handler ()
|
|||
postClothApplyR loomHash clothHash = do
|
||||
ep@(Entity personID person) <- requireAuth
|
||||
|
||||
(grantIDs, proposal, actor) <- runDB $ do
|
||||
(grantIDs, proposal, actor, loomID) <- runDB $ do
|
||||
(Entity loomID _, _, _, _, _, proposal) <- getCloth404 loomHash clothHash
|
||||
|
||||
grantIDs <-
|
||||
|
|
@ -636,7 +636,7 @@ postClothApplyR loomHash clothHash = do
|
|||
|
||||
actor <- getJust $ personActor person
|
||||
|
||||
return (map E.unValue grantIDs, proposal, actor)
|
||||
return (map E.unValue grantIDs, proposal, actor, loomID)
|
||||
|
||||
result <- runExceptT $ do
|
||||
|
||||
|
|
@ -652,10 +652,13 @@ postClothApplyR loomHash clothHash = do
|
|||
personHash <- encodeKeyHashid personID
|
||||
(maybeSummary, audience, apply) <-
|
||||
C.applyPatches personHash $ encodeRouteHome bundleRoute
|
||||
let cap = (LocalActorLoom loomID, LocalActorLoom loomHash, grantID)
|
||||
uCap <-
|
||||
encodeRouteHome . LoomOutboxItemR loomHash <$>
|
||||
encodeKeyHashid grantID
|
||||
applyC ep actor (Just uCap) maybeSummary audience apply
|
||||
(localRecips, remoteRecips, fwdHosts, action) <-
|
||||
C.makeServerInput (Just uCap) maybeSummary audience (AP.ApplyActivity apply)
|
||||
applyC ep actor (Just $ Left cap) localRecips remoteRecips fwdHosts action apply
|
||||
|
||||
case result of
|
||||
Left e -> setMessage $ toHtml e
|
||||
|
|
|
|||
|
|
@ -32,6 +32,7 @@ module Vervis.Handler.Deck
|
|||
, postDeckFollowR
|
||||
, postDeckUnfollowR
|
||||
|
||||
, getDeckStampR
|
||||
|
||||
|
||||
|
||||
|
|
@ -318,9 +319,11 @@ postDeckNewR = do
|
|||
personEntity@(Entity personID person) <- requireAuth
|
||||
personHash <- encodeKeyHashid personID
|
||||
(maybeSummary, audience, detail) <- C.createDeck personHash name desc
|
||||
(localRecips, remoteRecips, fwdHosts, action) <-
|
||||
C.makeServerInput Nothing maybeSummary audience $ AP.CreateActivity $ AP.Create (AP.CreateTicketTracker detail Nothing) Nothing
|
||||
actor <- runDB $ getJust $ personActor person
|
||||
result <-
|
||||
runExceptT $ createTicketTrackerC personEntity actor maybeSummary audience detail Nothing Nothing
|
||||
runExceptT $ createTicketTrackerC personEntity actor Nothing localRecips remoteRecips fwdHosts action detail Nothing Nothing
|
||||
|
||||
case result of
|
||||
Left e -> do
|
||||
|
|
@ -378,6 +381,8 @@ postDeckFollowR _ = error "Temporarily disabled"
|
|||
postDeckUnfollowR :: KeyHashid Deck -> Handler ()
|
||||
postDeckUnfollowR _ = error "Temporarily disabled"
|
||||
|
||||
getDeckStampR :: KeyHashid Deck -> KeyHashid SigKey -> Handler TypedContent
|
||||
getDeckStampR = servePerActorKey deckActor LocalActorDeck
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -21,6 +21,7 @@ module Vervis.Handler.Group
|
|||
, getGroupOutboxItemR
|
||||
, getGroupFollowersR
|
||||
|
||||
, getGroupStampR
|
||||
|
||||
|
||||
|
||||
|
|
@ -129,6 +130,9 @@ getGroupOutboxItemR = getOutboxItem GroupOutboxItemR groupActor
|
|||
getGroupFollowersR :: KeyHashid Group -> Handler TypedContent
|
||||
getGroupFollowersR = getActorFollowersCollection GroupFollowersR groupActor
|
||||
|
||||
getGroupStampR :: KeyHashid Group -> KeyHashid SigKey -> Handler TypedContent
|
||||
getGroupStampR = servePerActorKey groupActor LocalActorGroup
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -26,6 +26,8 @@ module Vervis.Handler.Loom
|
|||
, postLoomNewR
|
||||
, postLoomFollowR
|
||||
, postLoomUnfollowR
|
||||
|
||||
, getLoomStampR
|
||||
)
|
||||
where
|
||||
|
||||
|
|
@ -285,8 +287,10 @@ postLoomNewR = do
|
|||
|
||||
getJust $ personActor person
|
||||
|
||||
result <-
|
||||
runExceptT $ createPatchTrackerC personEntity actor maybeSummary audience detail repos Nothing Nothing
|
||||
result <- do
|
||||
(localRecips, remoteRecips, fwdHosts, action) <-
|
||||
C.makeServerInput Nothing maybeSummary audience $ AP.CreateActivity $ AP.Create (AP.CreatePatchTracker detail repos Nothing) Nothing
|
||||
runExceptT $ createPatchTrackerC personEntity actor Nothing localRecips remoteRecips fwdHosts action detail repos Nothing Nothing
|
||||
|
||||
case result of
|
||||
Left e -> do
|
||||
|
|
@ -306,3 +310,6 @@ postLoomFollowR _ = error "Temporarily disabled"
|
|||
|
||||
postLoomUnfollowR :: KeyHashid Loom -> Handler ()
|
||||
postLoomUnfollowR _ = error "Temporarily disabled"
|
||||
|
||||
getLoomStampR :: KeyHashid Loom -> KeyHashid SigKey -> Handler TypedContent
|
||||
getLoomStampR = servePerActorKey loomActor LocalActorLoom
|
||||
|
|
|
|||
|
|
@ -29,12 +29,15 @@ module Vervis.Handler.Person
|
|||
, postPersonUnfollowR
|
||||
|
||||
, postReplyR
|
||||
|
||||
, getPersonStampR
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Monad
|
||||
import Control.Monad.Trans.Except
|
||||
import Control.Monad.Trans.Reader
|
||||
import Data.List.NonEmpty (NonEmpty)
|
||||
import Data.Maybe
|
||||
import Data.Text (Text)
|
||||
import Data.Time.Clock
|
||||
|
|
@ -67,11 +70,11 @@ import Data.Either.Local
|
|||
import Database.Persist.Local
|
||||
|
||||
import Vervis.ActivityPub
|
||||
import Vervis.ActorKey
|
||||
import Vervis.API
|
||||
import Vervis.Data.Actor
|
||||
import Vervis.Federation.Auth
|
||||
import Vervis.Federation.Collab
|
||||
import Vervis.FedURI
|
||||
import Vervis.Foundation
|
||||
import Vervis.Model
|
||||
import Vervis.Model.Ident
|
||||
|
|
@ -272,12 +275,42 @@ postPersonOutboxR personHash = do
|
|||
Just (PersonR actorHash) | actorHash == personHash -> return ()
|
||||
_ -> throwE "Can't post activity attributed to someone else"
|
||||
|
||||
handle eperson actorDB (AP.Activity _mid _actorAP mcap summary audience _fulfills specific) =
|
||||
checkFederation remoteRecips = do
|
||||
federation <- asksSite $ appFederation . appSettings
|
||||
unless (federation || null remoteRecips) $
|
||||
throwE "Federation disabled, but remote recipients found"
|
||||
|
||||
handle eperson actorDB (AP.Activity _mid _actorAP muCap summary audience _fulfills specific) = do
|
||||
maybeCap <- traverse (nameExceptT "Capability" . parseActivityURI) muCap
|
||||
ParsedAudience localRecips remoteRecips blinded fwdHosts <- do
|
||||
mrecips <- parseAudience audience
|
||||
fromMaybeE mrecips "No recipients"
|
||||
checkFederation remoteRecips
|
||||
let action = AP.Action
|
||||
{ AP.actionCapability = muCap
|
||||
, AP.actionSummary = summary
|
||||
, AP.actionAudience = blinded
|
||||
, AP.actionFulfills = []
|
||||
, AP.actionSpecific = specific
|
||||
}
|
||||
run :: ( Entity Person
|
||||
-> Actor
|
||||
-> Maybe
|
||||
( Either
|
||||
(LocalActorBy Key, LocalActorBy KeyHashid, OutboxItemId)
|
||||
FedURI
|
||||
)
|
||||
-> RecipientRoutes
|
||||
-> [(Host, NonEmpty LocalURI)]
|
||||
-> [Host]
|
||||
-> AP.Action URIMode
|
||||
-> t
|
||||
)
|
||||
-> t
|
||||
run f = f eperson actorDB maybeCap localRecips remoteRecips fwdHosts action
|
||||
case specific of
|
||||
AP.AcceptActivity accept ->
|
||||
acceptC eperson actorDB summary audience accept
|
||||
AP.ApplyActivity apply ->
|
||||
applyC eperson actorDB mcap summary audience apply
|
||||
AP.AcceptActivity accept -> run acceptC accept
|
||||
AP.ApplyActivity apply -> run applyC apply
|
||||
AP.CreateActivity (AP.Create obj mtarget) ->
|
||||
case obj of
|
||||
{-
|
||||
|
|
@ -285,14 +318,13 @@ postPersonOutboxR personHash = do
|
|||
createNoteC eperson sharer summary audience note mtarget
|
||||
-}
|
||||
AP.CreateTicketTracker detail mlocal ->
|
||||
createTicketTrackerC eperson actorDB summary audience detail mlocal mtarget
|
||||
run createTicketTrackerC detail mlocal mtarget
|
||||
AP.CreateRepository detail vcs mlocal ->
|
||||
createRepositoryC eperson actorDB summary audience detail vcs mlocal mtarget
|
||||
run createRepositoryC detail vcs mlocal mtarget
|
||||
AP.CreatePatchTracker detail repos mlocal ->
|
||||
createPatchTrackerC eperson actorDB summary audience detail repos mlocal mtarget
|
||||
run createPatchTrackerC detail repos mlocal mtarget
|
||||
_ -> throwE "Unsupported Create 'object' type"
|
||||
AP.InviteActivity invite ->
|
||||
inviteC eperson actorDB mcap summary audience invite
|
||||
AP.InviteActivity invite -> run inviteC invite
|
||||
{-
|
||||
AddActivity (AP.Add obj target) ->
|
||||
case obj of
|
||||
|
|
@ -306,8 +338,7 @@ postPersonOutboxR personHash = do
|
|||
-}
|
||||
AP.OfferActivity (AP.Offer obj target) ->
|
||||
case obj of
|
||||
AP.OfferTicket ticket ->
|
||||
offerTicketC eperson actorDB summary audience ticket target
|
||||
AP.OfferTicket ticket -> run offerTicketC ticket target
|
||||
{-
|
||||
OfferDep dep ->
|
||||
offerDepC eperson sharer summary audience dep target
|
||||
|
|
@ -428,3 +459,6 @@ postPersonUnfollowR _ = error "Temporarily disabled"
|
|||
|
||||
postReplyR :: KeyHashid Message -> Handler ()
|
||||
postReplyR _ = error "Temporarily disabled"
|
||||
|
||||
getPersonStampR :: KeyHashid Person -> KeyHashid SigKey -> Handler TypedContent
|
||||
getPersonStampR = servePerActorKey personActor LocalActorPerson
|
||||
|
|
|
|||
|
|
@ -44,6 +44,7 @@ module Vervis.Handler.Repo
|
|||
|
||||
, postRepoLinkR
|
||||
|
||||
, getRepoStampR
|
||||
|
||||
|
||||
|
||||
|
|
@ -432,9 +433,11 @@ postRepoNewR = do
|
|||
personEntity@(Entity personID person) <- requireAuth
|
||||
personHash <- encodeKeyHashid personID
|
||||
(maybeSummary, audience, detail) <- C.createRepo personHash name desc
|
||||
(localRecips, remoteRecips, fwdHosts, action) <-
|
||||
C.makeServerInput Nothing maybeSummary audience $ AP.CreateActivity $ AP.Create (AP.CreateRepository detail vcs Nothing) Nothing
|
||||
actor <- runDB $ getJust $ personActor person
|
||||
result <-
|
||||
runExceptT $ createRepositoryC personEntity actor maybeSummary audience detail vcs Nothing Nothing
|
||||
runExceptT $ createRepositoryC personEntity actor Nothing localRecips remoteRecips fwdHosts action detail vcs Nothing Nothing
|
||||
|
||||
case result of
|
||||
Left e -> do
|
||||
|
|
@ -702,6 +705,9 @@ postRepoLinkR repoHash loomHash = do
|
|||
Right () -> setMessage "Repo successfully linked with loom!"
|
||||
redirect $ RepoR repoHash
|
||||
|
||||
getRepoStampR :: KeyHashid Repo -> KeyHashid SigKey -> Handler TypedContent
|
||||
getRepoStampR = servePerActorKey repoActor LocalActorRepo
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -2723,6 +2723,56 @@ changes hLocal ctx =
|
|||
update ticketID [Ticket495Title =. plain]
|
||||
-- 496
|
||||
, addFieldPrimRequired "Bundle" False "auto"
|
||||
-- 497
|
||||
, addEntities model_497_sigkey
|
||||
-- 498
|
||||
, addFieldRefRequired''
|
||||
"Forwarding"
|
||||
(do ibid <- insert Inbox498
|
||||
obid <- insert Outbox498
|
||||
fsid <- insert FollowerSet498
|
||||
insertEntity $ Actor498 "" "" defaultTime ibid obid fsid
|
||||
)
|
||||
(Just $ \ (Entity aidTemp aTemp) -> do
|
||||
fs <- selectKeysList ([] :: [Filter Forwarding498]) []
|
||||
for_ fs $ \ forwardingID -> do
|
||||
actorIDs <-
|
||||
sequenceA $ map runMaybeT
|
||||
[do fp <- MaybeT $ getValBy $ UniqueForwarderPerson498 forwardingID
|
||||
lift $ person498Actor <$> getJust (forwarderPerson498Sender fp)
|
||||
,do fg <- MaybeT $ getValBy $ UniqueForwarderGroup498 forwardingID
|
||||
lift $ group498Actor <$> getJust (forwarderGroup498Sender fg)
|
||||
,do fr <- MaybeT $ getValBy $ UniqueForwarderRepo498 forwardingID
|
||||
lift $ repo498Actor <$> getJust (forwarderRepo498Sender fr)
|
||||
,do fd <- MaybeT $ getValBy $ UniqueForwarderDeck498 forwardingID
|
||||
lift $ deck498Actor <$> getJust (forwarderDeck498Sender fd)
|
||||
,do fl <- MaybeT $ getValBy $ UniqueForwarderLoom498 forwardingID
|
||||
lift $ loom498Actor <$> getJust (forwarderLoom498Sender fl)
|
||||
]
|
||||
actorID <-
|
||||
case catMaybes actorIDs of
|
||||
[] -> error "No Forwarder* found!"
|
||||
[a] -> return a
|
||||
_ -> error "Multiple Forwarder* found!"
|
||||
update forwardingID [Forwarding498Forwarder =. actorID]
|
||||
|
||||
delete aidTemp
|
||||
delete $ actor498Inbox aTemp
|
||||
delete $ actor498Outbox aTemp
|
||||
delete $ actor498Followers aTemp
|
||||
)
|
||||
"forwarder"
|
||||
"Actor"
|
||||
-- 499
|
||||
, removeEntity "ForwarderPerson"
|
||||
-- 500
|
||||
, removeEntity "ForwarderGroup"
|
||||
-- 501
|
||||
, removeEntity "ForwarderRepo"
|
||||
-- 502
|
||||
, removeEntity "ForwarderDeck"
|
||||
-- 503
|
||||
, removeEntity "ForwarderLoom"
|
||||
]
|
||||
|
||||
migrateDB
|
||||
|
|
|
|||
|
|
@ -298,6 +298,7 @@ import Database.Persist.Sql (SqlBackend)
|
|||
import Text.Email.Validate (EmailAddress)
|
||||
import Web.Text (HTML, PandocMarkdown)
|
||||
|
||||
import Crypto.ActorKey
|
||||
import Development.PatchMediaType
|
||||
import Development.PatchMediaType.Persist
|
||||
|
||||
|
|
@ -669,3 +670,9 @@ model_494_mr_origin = $(schema "494_2022-09-17_mr_origin")
|
|||
|
||||
makeEntitiesMigration "495"
|
||||
$(modelFile "migrations/495_2022-09-21_ticket_title.model")
|
||||
|
||||
model_497_sigkey :: [Entity SqlBackend]
|
||||
model_497_sigkey = $(schema "497_2022-09-29_sigkey")
|
||||
|
||||
makeEntitiesMigration "498"
|
||||
$(modelFile "migrations/498_2022-10-03_forwarder.model")
|
||||
|
|
|
|||
|
|
@ -31,6 +31,7 @@ import Text.Email.Validate (EmailAddress)
|
|||
import Database.Persist.Schema.TH hiding (modelFile)
|
||||
import Yesod.Auth.Account (PersistUserCredentials (..))
|
||||
|
||||
import Crypto.ActorKey
|
||||
import Crypto.PublicVerifKey
|
||||
import Database.Persist.EmailAddress
|
||||
import Database.Persist.Graph.Class
|
||||
|
|
|
|||
|
|
@ -18,25 +18,44 @@ module Vervis.Persist.Actor
|
|||
, verifyLocalActivityExistsInDB
|
||||
, getRemoteActorURI
|
||||
, insertActor
|
||||
, updateOutboxItem
|
||||
, fillPerActorKeys
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Monad
|
||||
import Control.Monad.IO.Class
|
||||
import Control.Monad.Logger.CallStack
|
||||
import Control.Monad.Trans.Class
|
||||
import Control.Monad.Trans.Except
|
||||
import Control.Monad.Trans.Reader
|
||||
import Data.Text (Text)
|
||||
import Data.Traversable
|
||||
import Database.Persist
|
||||
import Database.Persist.Sql
|
||||
|
||||
import qualified Data.Text as T
|
||||
import qualified Database.Esqueleto as E
|
||||
|
||||
import Crypto.ActorKey
|
||||
import Database.Persist.JSON
|
||||
import Network.FedURI
|
||||
import Yesod.ActivityPub
|
||||
import Yesod.FedURI
|
||||
import Yesod.Hashids
|
||||
import Yesod.MonadSite
|
||||
|
||||
import qualified Web.ActivityPub as AP
|
||||
|
||||
import Control.Monad.Trans.Except.Local
|
||||
import Database.Persist.Local
|
||||
|
||||
import Vervis.Data.Actor
|
||||
import Vervis.FedURI
|
||||
import Vervis.Foundation
|
||||
import Vervis.Model
|
||||
import Vervis.Recipient
|
||||
import Vervis.Settings
|
||||
|
||||
getLocalActor
|
||||
:: MonadIO m => ActorId -> ReaderT SqlBackend m (LocalActorBy Key)
|
||||
|
|
@ -93,3 +112,35 @@ insertActor now name desc = do
|
|||
}
|
||||
actorID <- insert actor
|
||||
return $ Entity actorID actor
|
||||
|
||||
updateOutboxItem
|
||||
:: (MonadSite m, SiteEnv m ~ App)
|
||||
=> LocalActorBy Key
|
||||
-> OutboxItemId
|
||||
-> AP.Action URIMode
|
||||
-> ReaderT SqlBackend m LocalURI
|
||||
updateOutboxItem actorByKey itemID action = do
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
hLocal <- asksSite siteInstanceHost
|
||||
actorByHash <- hashLocalActor actorByKey
|
||||
itemHash <- encodeKeyHashid itemID
|
||||
let luId = encodeRouteLocal $ activityRoute actorByHash itemHash
|
||||
luActor = encodeRouteLocal $ renderLocalActor actorByHash
|
||||
doc = AP.Doc hLocal $ AP.makeActivity luId luActor action
|
||||
update itemID [OutboxItemActivity =. persistJSONObjectFromDoc doc]
|
||||
return luId
|
||||
|
||||
fillPerActorKeys :: Worker ()
|
||||
fillPerActorKeys = do
|
||||
perActor <- asksSite $ appPerActorKeys . appSettings
|
||||
when perActor $ do
|
||||
actorIDs <- runSiteDB $ E.select $ E.from $ \ (actor `E.LeftOuterJoin` sigkey) -> do
|
||||
E.on $ E.just (actor E.^. ActorId) E.==. sigkey E.?. SigKeyActor
|
||||
E.where_ $ E.isNothing $ sigkey E.?. SigKeyId
|
||||
return $ actor E.^. ActorId
|
||||
keys <- for actorIDs $ \ (E.Value actorID) -> do
|
||||
key <- liftIO generateActorKey
|
||||
return $ SigKey actorID key
|
||||
runSiteDB $ insertMany_ keys
|
||||
logInfo $
|
||||
T.concat ["Filled ", T.pack (show $ length keys), " actor keys"]
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
{- This file is part of Vervis.
|
||||
-
|
||||
- Written in 2016, 2018, 2019 by fr33domlover <fr33domlover@riseup.net>.
|
||||
- Written in 2016, 2018, 2019, 2022 by fr33domlover <fr33domlover@riseup.net>.
|
||||
-
|
||||
- ♡ Copying is an act of love. Please copy, reuse and share.
|
||||
-
|
||||
|
|
@ -113,6 +113,8 @@ data AppSettings = AppSettings
|
|||
|
||||
-- How often to generate a new actor key for making HTTP signatures
|
||||
, appActorKeyRotation :: TimeInterval
|
||||
-- | Whether to use personal actor keys, or an instance-wide key
|
||||
, appPerActorKeys :: Bool
|
||||
|
||||
-- | Use detailed request logging system
|
||||
, appDetailedRequestLogging :: Bool
|
||||
|
|
@ -224,6 +226,7 @@ instance FromJSON AppSettings where
|
|||
|
||||
appHttpSigTimeLimit <- interval <$> o .: "request-time-limit"
|
||||
appActorKeyRotation <- interval <$> o .: "actor-key-rotation"
|
||||
appPerActorKeys <- o .:? "per-actor-keys" .!= False
|
||||
|
||||
appDetailedRequestLogging <- o .:? "detailed-logging" .!= defaultDev
|
||||
appShouldLogAll <- o .:? "should-log-all" .!= defaultDev
|
||||
|
|
|
|||
|
|
@ -22,6 +22,8 @@ module Vervis.Web.Actor
|
|||
, getActorFollowersCollection
|
||||
, getFollowingCollection
|
||||
, handleRobotInbox
|
||||
, serveInstanceKey
|
||||
, servePerActorKey
|
||||
)
|
||||
where
|
||||
|
||||
|
|
@ -69,6 +71,7 @@ import qualified Data.Text.Lazy as TL
|
|||
import qualified Data.Vector as V
|
||||
import qualified Database.Esqueleto as E
|
||||
|
||||
import Crypto.ActorKey
|
||||
import Database.Persist.JSON
|
||||
import Network.FedURI
|
||||
import Web.ActivityPub hiding (Project (..), ActorLocal (..))
|
||||
|
|
@ -89,10 +92,11 @@ import Database.Persist.Local
|
|||
import Yesod.Persist.Local
|
||||
|
||||
import qualified Data.Aeson.Encode.Pretty.ToEncoding as P
|
||||
import qualified Web.ActivityPub as AP
|
||||
|
||||
import Vervis.ActivityPub
|
||||
import Vervis.ActorKey
|
||||
import Vervis.API
|
||||
import Vervis.Data.Actor
|
||||
import Vervis.FedURI
|
||||
import Vervis.Federation.Auth
|
||||
import Vervis.Foundation
|
||||
|
|
@ -489,3 +493,63 @@ handleRobotInbox recipByHash handleSpecific now auth body = do
|
|||
msig <- checkForwarding recipByHash
|
||||
let mfwd = (localRecips,) <$> msig
|
||||
handleSpecific now remoteAuthor body mfwd luActivity (activitySpecific $ actbActivity body)
|
||||
|
||||
actorKeyAP
|
||||
:: ( MonadSite m, SiteEnv m ~ site
|
||||
, SiteFedURI site, SiteFedURIMode site ~ u
|
||||
)
|
||||
=> Maybe (Route site) -> Route site -> ActorKey -> m (AP.PublicKey u)
|
||||
actorKeyAP maybeHolderR keyR akey = do
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
return AP.PublicKey
|
||||
{ AP.publicKeyId = LocalRefURI $ Left $ encodeRouteLocal keyR
|
||||
, AP.publicKeyExpires = Nothing
|
||||
, AP.publicKeyOwner =
|
||||
case maybeHolderR of
|
||||
Nothing -> AP.OwnerInstance
|
||||
Just holderR -> AP.OwnerActor $ encodeRouteLocal holderR
|
||||
, AP.publicKeyMaterial = actorKeyPublicBin akey
|
||||
}
|
||||
|
||||
serveInstanceKey
|
||||
:: ((ActorKey, ActorKey) -> ActorKey)
|
||||
-> Route App
|
||||
-> Handler TypedContent
|
||||
serveInstanceKey choose keyR = do
|
||||
maybeKeys <- asksSite appActorKeys
|
||||
case maybeKeys of
|
||||
Nothing -> notFound
|
||||
Just keys -> do
|
||||
akey <- liftIO $ do
|
||||
(akey1, akey2, _) <- readTVarIO keys
|
||||
return $ choose (akey1, akey2)
|
||||
keyAP <- actorKeyAP Nothing keyR akey
|
||||
provideHtmlAndAP keyAP $ redirectToPrettyJSON keyR
|
||||
|
||||
servePerActorKey'
|
||||
:: LocalActorBy KeyHashid
|
||||
-> KeyHashid SigKey
|
||||
-> ActorKey
|
||||
-> Handler TypedContent
|
||||
servePerActorKey' holderByHash keyHash akey = do
|
||||
let holderR = renderLocalActor holderByHash
|
||||
keyR = stampRoute holderByHash keyHash
|
||||
keyAP <- actorKeyAP (Just holderR) keyR akey
|
||||
provideHtmlAndAP keyAP $ redirectToPrettyJSON keyR
|
||||
|
||||
servePerActorKey
|
||||
:: (PersistRecordBackend holder SqlBackend, ToBackendKey SqlBackend holder)
|
||||
=> (holder -> ActorId)
|
||||
-> (KeyHashid holder -> LocalActorBy KeyHashid)
|
||||
-> KeyHashid holder
|
||||
-> KeyHashid SigKey
|
||||
-> Handler TypedContent
|
||||
servePerActorKey holderActor localActorHolder holderHash keyHash = do
|
||||
holderID <- decodeKeyHashid404 holderHash
|
||||
keyID <- decodeKeyHashid404 keyHash
|
||||
akey <- runDB $ do
|
||||
actorID <- holderActor <$> get404 holderID
|
||||
SigKey actorID' akey <- get404 keyID
|
||||
unless (actorID' == actorID) notFound
|
||||
return akey
|
||||
servePerActorKey' (localActorHolder holderHash) keyHash akey
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load diff
|
|
@ -78,6 +78,8 @@ module Web.ActivityPub
|
|||
, Undo (..)
|
||||
, Audience (..)
|
||||
, SpecificActivity (..)
|
||||
, Action (..)
|
||||
, makeActivity
|
||||
, Activity (..)
|
||||
|
||||
-- * Utilities
|
||||
|
|
@ -92,8 +94,13 @@ module Web.ActivityPub
|
|||
, hActivityPubForwarder
|
||||
, hForwardingSignature
|
||||
, hForwardedSignature
|
||||
, httpPostAP
|
||||
, httpPostAPBytes
|
||||
, Envelope ()
|
||||
, Errand ()
|
||||
, sending
|
||||
, retrying
|
||||
, deliver
|
||||
, forwarding
|
||||
, forward
|
||||
, Fetched (..)
|
||||
, fetchAP
|
||||
, fetchAP_T
|
||||
|
|
@ -115,6 +122,7 @@ import Control.Applicative ((<|>), optional)
|
|||
import Control.Exception (Exception, displayException, try)
|
||||
import Control.Monad
|
||||
import Control.Monad.IO.Class
|
||||
import Control.Monad.Trans.Class
|
||||
import Control.Monad.Trans.Except
|
||||
import Control.Monad.Trans.Writer (Writer)
|
||||
import Crypto.Hash hiding (Context)
|
||||
|
|
@ -132,7 +140,7 @@ import Data.Proxy
|
|||
import Data.Semigroup (Endo, First (..))
|
||||
import Data.Text (Text)
|
||||
import Data.Text.Encoding (encodeUtf8, decodeUtf8, decodeUtf8')
|
||||
import Data.Time.Clock (UTCTime)
|
||||
import Data.Time.Clock
|
||||
import Data.Traversable
|
||||
import Network.HTTP.Client hiding (Proxy, proxy)
|
||||
import Network.HTTP.Client.Conduit.ActivityPub (httpAPEither)
|
||||
|
|
@ -152,6 +160,7 @@ import qualified Data.ByteString.Lazy as BL
|
|||
import qualified Data.HashMap.Strict as M
|
||||
import qualified Data.List.NonEmpty as NE
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Encoding as TE
|
||||
import qualified Data.Vector as V
|
||||
import qualified Network.HTTP.Signature as S
|
||||
import qualified Text.Email.Parser as E
|
||||
|
|
@ -1679,6 +1688,25 @@ data SpecificActivity u
|
|||
| ResolveActivity (Resolve u)
|
||||
| UndoActivity (Undo u)
|
||||
|
||||
data Action u = Action
|
||||
{ actionCapability :: Maybe (ObjURI u)
|
||||
, actionSummary :: Maybe HTML
|
||||
, actionAudience :: Audience u
|
||||
, actionFulfills :: [ObjURI u]
|
||||
, actionSpecific :: SpecificActivity u
|
||||
}
|
||||
|
||||
makeActivity :: LocalURI -> LocalURI -> Action u -> Activity u
|
||||
makeActivity luId luActor Action{..} = Activity
|
||||
{ activityId = Just luId
|
||||
, activityActor = luActor
|
||||
, activityCapability = actionCapability
|
||||
, activitySummary = actionSummary
|
||||
, activityAudience = actionAudience
|
||||
, activityFulfills = actionFulfills
|
||||
, activitySpecific = actionSpecific
|
||||
}
|
||||
|
||||
data Activity u = Activity
|
||||
{ activityId :: Maybe LocalURI
|
||||
, activityActor :: LocalURI
|
||||
|
|
@ -1855,62 +1883,168 @@ hForwardedSignature = "Forwarded-Signature"
|
|||
-- * Compute HTTP signature and add _Signature_ request header
|
||||
-- * Perform the POST request
|
||||
-- * Verify the response status is 2xx
|
||||
{-
|
||||
httpPostAP
|
||||
:: (MonadIO m, UriMode u, ToJSON a)
|
||||
=> Manager
|
||||
-> ObjURI u
|
||||
-> NonEmpty HeaderName
|
||||
-> S.KeyId
|
||||
-> (ByteString -> S.Signature)
|
||||
-> Text
|
||||
-> Maybe (Either (ObjURI u) ByteString)
|
||||
-> a
|
||||
-> ObjURI u
|
||||
-> Maybe (Either (ObjURI u) ByteString)
|
||||
-> m (Either APPostError (Response ()))
|
||||
httpPostAP manager uri headers keyid sign uSender mfwd value =
|
||||
httpPostAPBytes manager uri headers keyid sign uSender mfwd $ encode value
|
||||
httpPostAP manager headers keyid sign uSender value =
|
||||
httpPostAPBytes manager headers keyid sign uSender $ encode value
|
||||
-}
|
||||
|
||||
data ForwardMode u
|
||||
= SendNoForward
|
||||
| SendAllowForward LocalURI
|
||||
| ForwardBy (ObjURI u) ByteString
|
||||
|
||||
data Envelope u = Envelope
|
||||
{ envelopeKey :: RefURI u
|
||||
, envelopeSign :: ByteString -> S.Signature
|
||||
, envelopeHolder :: Maybe LocalURI
|
||||
, envelopeBody :: BL.ByteString
|
||||
}
|
||||
|
||||
data Errand u = Errand
|
||||
{ errandKey :: RefURI u
|
||||
, errandSign :: ByteString -> S.Signature
|
||||
, errandHolder :: Bool
|
||||
, errandFwder :: LocalURI
|
||||
, errandBody :: BL.ByteString
|
||||
, errandProof :: ByteString
|
||||
}
|
||||
|
||||
-- | Like 'httpPostAP', except it takes the object as a raw lazy
|
||||
-- 'BL.ByteString'. It's your responsibility to make sure it's valid JSON.
|
||||
httpPostAPBytes
|
||||
:: (MonadIO m, UriMode u)
|
||||
=> Manager
|
||||
-> ObjURI u
|
||||
-> NonEmpty HeaderName
|
||||
-> S.KeyId
|
||||
-> RefURI u
|
||||
-> (ByteString -> S.Signature)
|
||||
-> Text
|
||||
-> Maybe (Either (ObjURI u) ByteString)
|
||||
-> Maybe LocalURI
|
||||
-> BL.ByteString
|
||||
-> ForwardMode u
|
||||
-> ObjURI u
|
||||
-> m (Either APPostError (Response ()))
|
||||
httpPostAPBytes manager uri headers keyid sign uSender mfwd body =
|
||||
httpPostAPBytes manager headers ruKey@(RefURI hKey _) sign mluHolder body fwd uInbox@(ObjURI hInbox _) =
|
||||
liftIO $ runExceptT $ do
|
||||
req <- requestFromURI $ uriFromObjURI uri
|
||||
req <- requestFromURI $ uriFromObjURI uInbox
|
||||
let digest = formatHttpBodyDigest SHA256 "SHA-256" $ hashlazy body
|
||||
req' =
|
||||
setRequestCheckStatus $
|
||||
consHeader hContentType typeActivityStreams2LD $
|
||||
consHeader hActivityPubActor (encodeUtf8 uSender) $
|
||||
maybe id (consHeader hActivityPubActor . TE.encodeUtf8 . renderObjURI . ObjURI hKey) mluHolder $
|
||||
consHeader hDigest digest $
|
||||
req { method = "POST"
|
||||
, requestBody = RequestBodyLBS body
|
||||
}
|
||||
req'' <- tryExceptT APPostErrorSig $ signRequest headers Nothing keyid sign Nothing req'
|
||||
keyid = S.KeyId $ TE.encodeUtf8 $ renderRefURI ruKey
|
||||
now <- lift getCurrentTime
|
||||
req'' <- except $ first APPostErrorSig $ signRequest headers Nothing keyid sign now req'
|
||||
req''' <-
|
||||
case mfwd of
|
||||
Nothing -> return req''
|
||||
Just (Left uRecip) ->
|
||||
tryExceptT APPostErrorSig $
|
||||
signRequestInto hForwardingSignature (hDigest :| [hActivityPubForwarder]) Nothing keyid sign Nothing $ consHeader hActivityPubForwarder (encodeUtf8 $ renderObjURI uRecip) req''
|
||||
Just (Right sig) ->
|
||||
case fwd of
|
||||
SendNoForward -> return req''
|
||||
SendAllowForward luRecip ->
|
||||
except $ first APPostErrorSig $
|
||||
signRequestInto hForwardingSignature (hDigest :| [hActivityPubForwarder]) Nothing keyid sign now $
|
||||
consHeader hActivityPubForwarder (encodeUtf8 $ renderObjURI $ ObjURI hInbox luRecip) req''
|
||||
ForwardBy uSender sig ->
|
||||
return $
|
||||
consHeader hForwardedSignature sig $
|
||||
consHeader hActivityPubForwarder (encodeUtf8 uSender)
|
||||
consHeader hActivityPubForwarder (encodeUtf8 $ renderObjURI uSender)
|
||||
req''
|
||||
tryExceptT APPostErrorHTTP $ httpNoBody req''' manager
|
||||
where
|
||||
consHeader n b r = r { requestHeaders = (n, b) : requestHeaders r }
|
||||
tryExceptT adapt action = ExceptT $ first adapt <$> try action
|
||||
|
||||
sending
|
||||
:: UriMode u
|
||||
=> LocalRefURI
|
||||
-> (ByteString -> S.Signature)
|
||||
-> Bool
|
||||
-> ObjURI u
|
||||
-> LocalURI
|
||||
-> Action u
|
||||
-> Envelope u
|
||||
sending lruKey sign holder uActor@(ObjURI hActor luActor) luId action =
|
||||
Envelope
|
||||
{ envelopeKey = RefURI hActor lruKey
|
||||
, envelopeSign = sign
|
||||
, envelopeHolder = guard holder >> Just luActor
|
||||
, envelopeBody = encode $ Doc hActor $ makeActivity luId luActor action
|
||||
}
|
||||
|
||||
retrying
|
||||
:: RefURI u
|
||||
-> (ByteString -> S.Signature)
|
||||
-> Maybe LocalURI
|
||||
-> BL.ByteString
|
||||
-> Envelope u
|
||||
retrying = Envelope
|
||||
|
||||
forwarding
|
||||
:: LocalRefURI
|
||||
-> (ByteString -> S.Signature)
|
||||
-> Bool
|
||||
-> ObjURI u
|
||||
-> BL.ByteString
|
||||
-> ByteString
|
||||
-> Errand u
|
||||
forwarding lruKey sign holder (ObjURI hFwder luFwder) body sig =
|
||||
Errand
|
||||
{ errandKey = RefURI hFwder lruKey
|
||||
, errandSign = sign
|
||||
, errandHolder = holder
|
||||
, errandFwder = luFwder
|
||||
, errandBody = body
|
||||
, errandProof = sig
|
||||
}
|
||||
|
||||
deliver
|
||||
:: (MonadIO m, UriMode u)
|
||||
=> Manager
|
||||
-> NonEmpty HeaderName
|
||||
-> Envelope u
|
||||
-> Maybe LocalURI
|
||||
-> ObjURI u
|
||||
-> m (Either APPostError (Response ()))
|
||||
deliver manager headers (Envelope ruKey sign mluHolder body) mluFwd uInbox =
|
||||
httpPostAPBytes
|
||||
manager
|
||||
headers
|
||||
ruKey
|
||||
sign
|
||||
mluHolder
|
||||
body
|
||||
(maybe SendNoForward SendAllowForward mluFwd)
|
||||
uInbox
|
||||
|
||||
forward
|
||||
:: (MonadIO m, UriMode u)
|
||||
=> Manager
|
||||
-> NonEmpty HeaderName
|
||||
-> Errand u
|
||||
-> ObjURI u
|
||||
-> m (Either APPostError (Response ()))
|
||||
forward manager headers (Errand ruKey@(RefURI hKey _) sign holder luFwder body sig) uInbox =
|
||||
httpPostAPBytes
|
||||
manager
|
||||
headers
|
||||
ruKey
|
||||
sign
|
||||
(guard holder >> Just luFwder)
|
||||
body
|
||||
(ForwardBy (ObjURI hKey luFwder) sig)
|
||||
uInbox
|
||||
|
||||
-- | Result of GETing the keyId URI and processing the JSON document.
|
||||
data Fetched = Fetched
|
||||
{ fetchedPublicKey :: PublicVerifKey
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
{- This file is part of Vervis.
|
||||
-
|
||||
- Written in 2019 by fr33domlover <fr33domlover@riseup.net>.
|
||||
- Written in 2019, 2022 by fr33domlover <fr33domlover@riseup.net>.
|
||||
-
|
||||
- ♡ Copying is an act of love. Please copy, reuse and share.
|
||||
-
|
||||
|
|
@ -15,22 +15,33 @@
|
|||
|
||||
module Yesod.ActivityPub
|
||||
( YesodActivityPub (..)
|
||||
|
||||
, prepareToSend
|
||||
, prepareToRetry
|
||||
, deliverActivity
|
||||
, deliverActivityBL
|
||||
, deliverActivityBL'
|
||||
, deliverActivityExcept
|
||||
, deliverActivityThrow
|
||||
|
||||
, prepareToForward
|
||||
, forwardActivity
|
||||
, forwardActivityExcept
|
||||
, forwardActivityThrow
|
||||
|
||||
, redirectToPrettyJSON
|
||||
|
||||
, provideHtmlAndAP
|
||||
, provideHtmlAndAP'
|
||||
, provideHtmlAndAP''
|
||||
, provideHtmlFeedAndAP
|
||||
|
||||
, hostIsLocal
|
||||
, verifyHostLocal
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Exception
|
||||
import Control.Exception.Base
|
||||
import Control.Monad
|
||||
import Control.Monad.IO.Class
|
||||
import Control.Monad.Logger.CallStack
|
||||
import Control.Monad.Trans.Except
|
||||
import Control.Monad.Trans.Writer
|
||||
|
|
@ -56,6 +67,8 @@ import qualified Data.Text as T
|
|||
|
||||
import Network.HTTP.Signature
|
||||
|
||||
import qualified Network.HTTP.Signature as S
|
||||
|
||||
import Database.Persist.JSON
|
||||
import Network.FedURI
|
||||
import Web.ActivityPub
|
||||
|
|
@ -63,18 +76,307 @@ import Yesod.FedURI
|
|||
import Yesod.MonadSite
|
||||
import Yesod.RenderSource
|
||||
|
||||
import qualified Web.ActivityPub as AP
|
||||
|
||||
class (Yesod site, SiteFedURI site) => YesodActivityPub site where
|
||||
siteInstanceHost :: site -> Authority (SiteFedURIMode site)
|
||||
sitePostSignedHeaders :: site -> NonEmpty HeaderName
|
||||
{-
|
||||
siteGetHttpSign :: (MonadSite m, SiteEnv m ~ site)
|
||||
=> m (KeyId, ByteString -> Signature)
|
||||
{-
|
||||
siteSigVerRequiredHeaders :: site -> [HeaderName]
|
||||
siteSigVerWantedHeaders :: site -> [HeaderName]
|
||||
siteSigVerSeconds :: site -> Int
|
||||
-}
|
||||
|
||||
deliverActivity'
|
||||
prepareToSend
|
||||
:: (MonadSite m, SiteEnv m ~ site, SiteFedURI site, SiteFedURIMode site ~ u)
|
||||
=> Route site
|
||||
-> (ByteString -> S.Signature)
|
||||
-> Bool
|
||||
-> Route site
|
||||
-> Route site
|
||||
-> AP.Action u
|
||||
-> m (Envelope u)
|
||||
prepareToSend keyR sign holder actorR idR action = do
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
let lruKey = LocalRefURI $ Left $ encodeRouteLocal keyR
|
||||
uActor = encodeRouteHome actorR
|
||||
luId = encodeRouteLocal idR
|
||||
return $ AP.sending lruKey sign holder uActor luId action
|
||||
|
||||
prepareToRetry
|
||||
:: (MonadSite m, SiteEnv m ~ site, SiteFedURI site, SiteFedURIMode site ~ u)
|
||||
=> Route site
|
||||
-> (ByteString -> S.Signature)
|
||||
-> Maybe (Route site)
|
||||
-> BL.ByteString
|
||||
-> m (Envelope u)
|
||||
prepareToRetry keyR sign mHolderR body = do
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
let ruKey =
|
||||
let ObjURI h lu = encodeRouteHome keyR
|
||||
in RefURI h $ LocalRefURI $ Left lu
|
||||
mluHolder = encodeRouteLocal <$> mHolderR
|
||||
return $ AP.retrying ruKey sign mluHolder body
|
||||
|
||||
deliverActivity
|
||||
:: ( MonadSite m, SiteEnv m ~ site, SiteFedURIMode site ~ u
|
||||
, YesodActivityPub site
|
||||
, HasHttpManager site
|
||||
)
|
||||
=> Envelope u
|
||||
-> Maybe LocalURI
|
||||
-> ObjURI u
|
||||
-> m (Either APPostError (Response ()))
|
||||
deliverActivity envelope mluFwd uInbox = do
|
||||
manager <- asksSite getHttpManager
|
||||
headers <- asksSite sitePostSignedHeaders
|
||||
AP.deliver manager headers envelope mluFwd uInbox
|
||||
|
||||
deliverActivityExcept
|
||||
:: ( MonadSite m, SiteEnv m ~ site, SiteFedURIMode site ~ u
|
||||
, YesodActivityPub site
|
||||
, HasHttpManager site
|
||||
)
|
||||
=> Envelope u
|
||||
-> Maybe LocalURI
|
||||
-> ObjURI u
|
||||
-> ExceptT APPostError m (Response ())
|
||||
deliverActivityExcept envelope mluFwd uInbox =
|
||||
ExceptT $ deliverActivity envelope mluFwd uInbox
|
||||
|
||||
deliverActivityThrow
|
||||
:: ( MonadSite m, SiteEnv m ~ site, SiteFedURIMode site ~ u
|
||||
, YesodActivityPub site
|
||||
, HasHttpManager site
|
||||
)
|
||||
=> Envelope u
|
||||
-> Maybe LocalURI
|
||||
-> ObjURI u
|
||||
-> m (Response ())
|
||||
deliverActivityThrow envelope mluFwd uInbox = do
|
||||
result <- deliverActivity envelope mluFwd uInbox
|
||||
case result of
|
||||
Left e -> liftIO $ throwIO e
|
||||
Right response -> return response
|
||||
|
||||
prepareToForward
|
||||
:: (MonadSite m, SiteEnv m ~ site, SiteFedURI site, SiteFedURIMode site ~ u)
|
||||
=> Route site
|
||||
-> (ByteString -> S.Signature)
|
||||
-> Bool
|
||||
-> Route site
|
||||
-> BL.ByteString
|
||||
-> ByteString
|
||||
-> m (Errand u)
|
||||
prepareToForward keyR sign holder fwderR body sig = do
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
let lruKey = LocalRefURI $ Left $ encodeRouteLocal keyR
|
||||
uFwder = encodeRouteHome fwderR
|
||||
return $ AP.forwarding lruKey sign holder uFwder body sig
|
||||
|
||||
forwardActivity
|
||||
:: ( MonadSite m, SiteEnv m ~ site
|
||||
, SiteFedURI site, SiteFedURIMode site ~ u
|
||||
, HasHttpManager site
|
||||
, YesodActivityPub site
|
||||
)
|
||||
=> Errand u
|
||||
-> ObjURI u
|
||||
-> m (Either APPostError (Response ()))
|
||||
forwardActivity errand uInbox = do
|
||||
manager <- asksSite getHttpManager
|
||||
headers <- asksSite sitePostSignedHeaders
|
||||
AP.forward manager headers errand uInbox
|
||||
|
||||
forwardActivityExcept
|
||||
:: ( MonadSite m, SiteEnv m ~ site
|
||||
, SiteFedURI site, SiteFedURIMode site ~ u
|
||||
, HasHttpManager site
|
||||
, YesodActivityPub site
|
||||
)
|
||||
=> Errand u
|
||||
-> ObjURI u
|
||||
-> ExceptT APPostError m (Response ())
|
||||
forwardActivityExcept errand uInbox = ExceptT $ forwardActivity errand uInbox
|
||||
|
||||
forwardActivityThrow
|
||||
:: ( MonadSite m, SiteEnv m ~ site
|
||||
, SiteFedURI site, SiteFedURIMode site ~ u
|
||||
, HasHttpManager site
|
||||
, YesodActivityPub site
|
||||
)
|
||||
=> Errand u
|
||||
-> ObjURI u
|
||||
-> m (Response ())
|
||||
forwardActivityThrow errand uInbox = do
|
||||
result <- forwardActivity errand uInbox
|
||||
case result of
|
||||
Left e -> liftIO $ throwIO e
|
||||
Right response -> return response
|
||||
|
||||
{-
|
||||
-- | An 'AP.Activity' ready for sending, attached to an actor key ready to sign
|
||||
-- it
|
||||
data Envelope u = Envelope
|
||||
{ envelopeKey :: LocalRefURI
|
||||
, envelopeSign :: ByteString -> S.Signature
|
||||
, envelopeHolder :: Bool
|
||||
, envelopeActor :: ObjURI u
|
||||
, envelopeId :: LocalURI
|
||||
, envelopeAction :: Action u
|
||||
}
|
||||
-}
|
||||
|
||||
{-
|
||||
-- | An 'AP.Activity' ready for sending, attached to an actor key ready to sign
|
||||
-- it
|
||||
data Envelope site = Envelope
|
||||
{ -- | Signing key's identifier URI
|
||||
envelopeKey :: Route site
|
||||
-- | Signing function, producing a signature for a given input
|
||||
, envelopeSign :: ByteString -> Signature
|
||||
-- | Whether the signing key is used for the whole instance, or a
|
||||
-- personal key used only by one actor
|
||||
, envelopeSharedKey :: Bool
|
||||
-- | The actor signing and sending the activity
|
||||
, envelopeActor :: Route site
|
||||
-- | Activity's ID URI
|
||||
, envelopeId :: Route site
|
||||
-- | Activity document, just needing its actor and id to be filled in
|
||||
, envelopeAction :: AP.Action (SiteFedURIMode site)
|
||||
}
|
||||
-}
|
||||
|
||||
{-
|
||||
prepareActivity
|
||||
:: Route site
|
||||
-> (ByteString -> S.Signature)
|
||||
-> Bool
|
||||
-> Route site
|
||||
-> Route site
|
||||
-> AP.Action u
|
||||
-> m (Envelope u)
|
||||
prepareActivity keyR sign holder actorR idR action = do
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
let lruKey = LocalRefURI $ Left $ encodeRouteLocal keyR
|
||||
uActor = encodeRouteHome actorR
|
||||
luId = encodeRouteLocal idR
|
||||
return $ Envelope lruKey sign holder uActor luId action
|
||||
|
||||
return $ AP.send manager headers lruKey sign holder uActor luId action
|
||||
|
||||
sendActivity
|
||||
:: Envelope u
|
||||
-> Maybe LocalURI
|
||||
-> ObjURI u
|
||||
-> m (Either AP.APPostError (Response ()))
|
||||
sendActivity (Envelope lruKey sign holder uActor luId action)
|
||||
-}
|
||||
|
||||
{-
|
||||
prepareSendActivity
|
||||
:: ( MonadSite m
|
||||
, SiteEnv m ~ site
|
||||
, SiteFedURIMode site ~ u
|
||||
, HasHttpManager site
|
||||
, YesodActivityPub site
|
||||
)
|
||||
=> Route site
|
||||
-> (ByteString -> S.Signature)
|
||||
-> Bool
|
||||
-> Route site
|
||||
-> Route site
|
||||
-> AP.Action u
|
||||
-> m (Maybe LocalURI -> ObjURI u -> m (Either AP.APPostError (Response ())))
|
||||
prepareSendActivity keyR sign holder actorR idR action = do
|
||||
manager <- asksSite getHttpManager
|
||||
headers <- asksSite sitePostSignedHeaders
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
let lruKey = LocalRefURI $ Left $ encodeRouteLocal keyR
|
||||
uActor = encodeRouteHome actorR
|
||||
luId = encodeRouteLocal idR
|
||||
return $ AP.send manager headers lruKey sign holder uActor luId action
|
||||
|
||||
resendActivity
|
||||
:: ( MonadSite m
|
||||
, SiteEnv m ~ site
|
||||
, SiteFedURIMode site ~ u
|
||||
, HasHttpManager site
|
||||
, YesodActivityPub site
|
||||
)
|
||||
=> Route site
|
||||
-> (ByteString -> S.Signature)
|
||||
-> Maybe (Route site)
|
||||
-> BL.ByteString
|
||||
-> Maybe LocalURI
|
||||
-> ObjURI u
|
||||
-> m (Either AP.APPostError (Response ()))
|
||||
resendActivity keyR sign mHolderR body mluFwd uInbox = do
|
||||
manager <- asksSite getHttpManager
|
||||
headers <- asksSite sitePostSignedHeaders
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
let ruKey =
|
||||
let ObjURI h lu = encodeRouteHome keyR
|
||||
in RefURI h $ LocalRefURI $ Left lu
|
||||
mluHolder = encodeRouteLocal <$> mHolderR
|
||||
AP.resend manager headers ruKey sign mluHolder body mluFwd uInbox
|
||||
|
||||
forwardActivity
|
||||
:: ( MonadSite m
|
||||
, SiteEnv m ~ site
|
||||
, SiteFedURIMode site ~ u
|
||||
, HasHttpManager site
|
||||
, YesodActivityPub site
|
||||
)
|
||||
-> Route site
|
||||
-> (ByteString -> S.Signature)
|
||||
-> Bool
|
||||
-> Route site
|
||||
-> BL.ByteString
|
||||
-> ByteString
|
||||
-> ObjURI u
|
||||
-> m (Either APPostError (Response ()))
|
||||
forwardActivity keyR sign holder fwderR body sig uInbox = do
|
||||
manager <- asksSite getHttpManager
|
||||
headers <- asksSite sitePostSignedHeaders
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
let lruKey = LocalRefURI $ Left $ encodeRouteLocal keyR
|
||||
uFwder = encodeRouteHome fwderR
|
||||
AP.forward lruKey sign holder uFwder body sig uInbox
|
||||
-}
|
||||
|
||||
{-
|
||||
data Stamp site = Stamp
|
||||
{ stampActor :: Route site
|
||||
, stampKey :: Route site
|
||||
, stampSign :: ByteString -> Signature
|
||||
}
|
||||
|
||||
-- | An 'AP.Activity' ready for sending, attached to an actor key ready to sign
|
||||
-- it
|
||||
data Envelope site = Envelope
|
||||
{ -- | Activity document, just needing its actor and id to be filled in
|
||||
envelopeDoc :: AP.Action (SiteFedURIMode site)
|
||||
-- | Activity's ID URI
|
||||
, envelopeId :: Route site
|
||||
-- | The actor signing and sending the activity
|
||||
, envelopeActor :: Route site
|
||||
-- | Signing key's identifier URI
|
||||
, envelopeKey :: Route site
|
||||
-- | Signing function, producing a signature for a given input
|
||||
, envelopeSign :: ByteString -> Signature
|
||||
}
|
||||
|
||||
deliverActivityBL
|
||||
:: ( MonadSite m
|
||||
, SiteEnv m ~ site
|
||||
, SiteFedURIMode site ~ u
|
||||
|
|
@ -83,13 +385,15 @@ deliverActivity'
|
|||
)
|
||||
=> ObjURI u
|
||||
-> Maybe (ObjURI u)
|
||||
-> Text
|
||||
-> Stamp
|
||||
-> BL.ByteString
|
||||
-> m (Either APPostError (Response ()))
|
||||
deliverActivity' inbox mfwd sender body = do
|
||||
deliverActivityBL inbox mfwd (Stamp actorR keyR sign) body = do
|
||||
manager <- asksSite getHttpManager
|
||||
headers <- asksSite sitePostSignedHeaders
|
||||
(keyid, sign) <- siteGetHttpSign
|
||||
(sender, keyid) <- do
|
||||
renderUrl <- askUrlRender
|
||||
return (renderUrl actorR, KeyId $ renderUrl keyR)
|
||||
result <-
|
||||
httpPostAPBytes
|
||||
manager inbox headers keyid sign sender (Left <$> mfwd) body
|
||||
|
|
@ -115,48 +419,24 @@ deliverActivity
|
|||
)
|
||||
=> ObjURI u
|
||||
-> Maybe (ObjURI u)
|
||||
-> Doc Activity u
|
||||
-> Envelope site
|
||||
-> m (Either APPostError (Response ()))
|
||||
deliverActivity inbox mfwd doc@(Doc hAct activity) =
|
||||
let sender = renderObjURI $ ObjURI hAct (activityActor activity)
|
||||
body = encode doc
|
||||
in deliverActivity' inbox mfwd sender body
|
||||
deliverActivity inbox mfwd (Envelope action idR actorR keyR sign) = do
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
hLocal <- asksSite siteInstanceHost
|
||||
let body =
|
||||
encode $ Doc hLocal $
|
||||
makeActivity
|
||||
(encodeRouteLocal idR) (encodeRouteLocal actorR) action
|
||||
deliverActivityBL inbox mfwd (Stamp actorR keyR sign) body
|
||||
|
||||
deliverActivityBL
|
||||
:: ( MonadSite m
|
||||
, SiteEnv m ~ site
|
||||
, SiteFedURIMode site ~ u
|
||||
, HasHttpManager site
|
||||
, YesodActivityPub site
|
||||
)
|
||||
=> ObjURI u
|
||||
-> Maybe (ObjURI u)
|
||||
-> Route site
|
||||
-> BL.ByteString
|
||||
-> m (Either APPostError (Response ()))
|
||||
deliverActivityBL inbox mfwd senderR body = do
|
||||
renderUrl <- askUrlRender
|
||||
let sender = renderUrl senderR
|
||||
deliverActivity' inbox mfwd sender body
|
||||
|
||||
deliverActivityBL'
|
||||
:: ( MonadSite m
|
||||
, SiteEnv m ~ site
|
||||
, SiteFedURIMode site ~ u
|
||||
, HasHttpManager site
|
||||
, YesodActivityPub site
|
||||
)
|
||||
=> ObjURI u
|
||||
-> Maybe (ObjURI u)
|
||||
-> BL.ByteString
|
||||
-> m (Either APPostError (Response ()))
|
||||
deliverActivityBL' inbox mfwd body = do
|
||||
sender <-
|
||||
case M.lookup ("actor" :: Text) =<< decode body of
|
||||
Just (String t) -> return t
|
||||
_ ->
|
||||
liftIO $ throwIO $ userError "Couldn't extract actor from body"
|
||||
deliverActivity' inbox mfwd sender body
|
||||
data Errand site = Errand
|
||||
{ errandDoc :: BL.ByteString
|
||||
, errandProof :: ByteString
|
||||
, errandActor :: Route site
|
||||
, errandKey :: Route site
|
||||
, errandSign :: ByteString -> Signature
|
||||
}
|
||||
|
||||
forwardActivity
|
||||
:: ( MonadSite m
|
||||
|
|
@ -166,18 +446,16 @@ forwardActivity
|
|||
, YesodActivityPub site
|
||||
)
|
||||
=> ObjURI u
|
||||
-> ByteString
|
||||
-> Route site
|
||||
-> BL.ByteString
|
||||
-> Errand site
|
||||
-> m (Either APPostError (Response ()))
|
||||
forwardActivity inbox sig rSender body = do
|
||||
forwardActivity inbox (Errand doc sig actorR keyR sign) = do
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
manager <- asksSite getHttpManager
|
||||
headers <- asksSite sitePostSignedHeaders
|
||||
(keyid, sign) <- siteGetHttpSign
|
||||
renderUrl <- askUrlRender
|
||||
let sender = renderUrl rSender
|
||||
result <-
|
||||
httpPostAPBytes manager inbox headers keyid sign sender (Just $ Right sig) body
|
||||
let uActor = encodeRouteHome actorR
|
||||
lruKey = LocalRefURI $ Left $ encodeRouteLocal keyR
|
||||
result <- AP.forward manager headers uActor lruKey sign doc inbox sig
|
||||
case result of
|
||||
Left err ->
|
||||
logError $ T.concat
|
||||
|
|
@ -190,6 +468,7 @@ forwardActivity inbox sig rSender body = do
|
|||
, "> success: ", T.pack $ show $ responseStatus resp
|
||||
]
|
||||
return result
|
||||
-}
|
||||
|
||||
redirectToPrettyJSON
|
||||
:: (MonadHandler m, HandlerSite m ~ site) => Route site -> m a
|
||||
|
|
|
|||
37
th/models
37
th/models
|
|
@ -118,6 +118,12 @@ Actor
|
|||
UniqueActorOutbox outbox
|
||||
UniqueActorFollowers followers
|
||||
|
||||
SigKey
|
||||
actor ActorId
|
||||
material ActorKey
|
||||
|
||||
UniqueSigKey actor
|
||||
|
||||
Person
|
||||
username Username
|
||||
login Text
|
||||
|
|
@ -161,40 +167,11 @@ Forwarding
|
|||
activity RemoteActivityId
|
||||
activityRaw ByteString
|
||||
signature ByteString
|
||||
forwarder ActorId
|
||||
running Bool
|
||||
|
||||
UniqueForwarding recipient activity
|
||||
|
||||
ForwarderPerson
|
||||
task ForwardingId
|
||||
sender PersonId
|
||||
|
||||
UniqueForwarderPerson task
|
||||
|
||||
ForwarderGroup
|
||||
task ForwardingId
|
||||
sender GroupId
|
||||
|
||||
UniqueForwarderGroup task
|
||||
|
||||
ForwarderRepo
|
||||
task ForwardingId
|
||||
sender RepoId
|
||||
|
||||
UniqueForwarderRepo task
|
||||
|
||||
ForwarderLoom
|
||||
task ForwardingId
|
||||
sender LoomId
|
||||
|
||||
UniqueForwarderLoom task
|
||||
|
||||
ForwarderDeck
|
||||
task ForwardingId
|
||||
sender DeckId
|
||||
|
||||
UniqueForwarderDeck task
|
||||
|
||||
-- ========================================================================= --
|
||||
-- ========================================================================= --
|
||||
|
||||
|
|
|
|||
10
th/routes
10
th/routes
|
|
@ -150,6 +150,8 @@
|
|||
|
||||
/reply/#MessageKeyHashid ReplyR POST
|
||||
|
||||
/people/#PersonKeyHashid/stamps/#SigKeyKeyHashid PersonStampR GET
|
||||
|
||||
---- Group ------------------------------------------------------------------
|
||||
|
||||
/groups/#GroupKeyHashid GroupR GET
|
||||
|
|
@ -158,6 +160,8 @@
|
|||
/groups/#GroupKeyHashid/outbox/#OutboxItemKeyHashid GroupOutboxItemR GET
|
||||
/groups/#GroupKeyHashid/followers GroupFollowersR GET
|
||||
|
||||
/groups/#GroupKeyHashid/stamps/#SigKeyKeyHashid GroupStampR GET
|
||||
|
||||
---- Repo --------------------------------------------------------------------
|
||||
|
||||
/repos/#RepoKeyHashid RepoR GET
|
||||
|
|
@ -186,6 +190,8 @@
|
|||
|
||||
/repos/#RepoKeyHashid/enable-loom/#LoomKeyHashid RepoLinkR POST
|
||||
|
||||
/repos/#RepoKeyHashid/stamps/#SigKeyKeyHashid RepoStampR GET
|
||||
|
||||
---- Deck --------------------------------------------------------------------
|
||||
|
||||
/decks/#DeckKeyHashid DeckR GET
|
||||
|
|
@ -203,6 +209,8 @@
|
|||
/decks/#DeckKeyHashid/follow DeckFollowR POST
|
||||
/decks/#DeckKeyHashid/unfollow DeckUnfollowR POST
|
||||
|
||||
/decks/#DeckKeyHashid/stamps/#SigKeyKeyHashid DeckStampR GET
|
||||
|
||||
---- Ticket ------------------------------------------------------------------
|
||||
|
||||
/decks/#DeckKeyHashid/tickets/#TicketDeckKeyHashid TicketR GET
|
||||
|
|
@ -248,6 +256,8 @@
|
|||
/looms/#LoomKeyHashid/follow LoomFollowR POST
|
||||
/looms/#LoomKeyHashid/unfollow LoomUnfollowR POST
|
||||
|
||||
/looms/#LoomKeyHashid/stamps/#SigKeyKeyHashid LoomStampR GET
|
||||
|
||||
---- Cloth -------------------------------------------------------------------
|
||||
|
||||
/looms/#LoomKeyHashid/cloths/#TicketLoomKeyHashid ClothR GET
|
||||
|
|
|
|||
|
|
@ -46,6 +46,7 @@ library
|
|||
Control.Concurrent.Local
|
||||
Control.Concurrent.ResultShare
|
||||
Control.Monad.Trans.Except.Local
|
||||
Crypto.ActorKey
|
||||
Crypto.PubKey.Encoding
|
||||
Crypto.PublicVerifKey
|
||||
Darcs.Local.Repository
|
||||
|
|
@ -127,7 +128,6 @@ library
|
|||
|
||||
Vervis.Access
|
||||
Vervis.ActivityPub
|
||||
Vervis.ActorKey
|
||||
Vervis.API
|
||||
Vervis.Avatar
|
||||
Vervis.BinaryBody
|
||||
|
|
@ -144,7 +144,6 @@ library
|
|||
Vervis.Data.Collab
|
||||
Vervis.Data.Ticket
|
||||
|
||||
Vervis.Delivery
|
||||
Vervis.Discussion
|
||||
--Vervis.Federation
|
||||
Vervis.Federation.Auth
|
||||
|
|
@ -231,6 +230,7 @@ library
|
|||
|
||||
Vervis.Web.Actor
|
||||
Vervis.Web.Darcs
|
||||
Vervis.Web.Delivery
|
||||
Vervis.Web.Discussion
|
||||
Vervis.Web.Git
|
||||
Vervis.Web.Repo
|
||||
|
|
|
|||
Loading…
Reference in a new issue