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:
parent
3c7b9f33e4
commit
32c87e3839
36 changed files with 2197 additions and 1584 deletions
|
@ -40,6 +40,9 @@ actor-key-rotation:
|
||||||
amount: 1
|
amount: 1
|
||||||
unit: days
|
unit: days
|
||||||
|
|
||||||
|
# Whether to use personal actor keys, or an instance-wide key
|
||||||
|
per-actor-keys: false
|
||||||
|
|
||||||
###############################################################################
|
###############################################################################
|
||||||
# Development
|
# 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/>.
|
- <http://creativecommons.org/publicdomain/zero/1.0/>.
|
||||||
-}
|
-}
|
||||||
|
|
||||||
module Vervis.ActorKey
|
module Crypto.ActorKey
|
||||||
( ActorKey ()
|
( ActorKey ()
|
||||||
, generateActorKey
|
, generateActorKey
|
||||||
, actorKeyRotator
|
, actorKeyRotator
|
||||||
, actorKeyPublicBin
|
, actorKeyPublicBin
|
||||||
, actorKeySign
|
, actorKeySign
|
||||||
-- , actorKeyVerify
|
, actorKeyVerify
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
|
@ -195,3 +195,7 @@ actorKeyPublicBin = fromEd25519 . actorKeyPublic
|
||||||
|
|
||||||
actorKeySign :: ActorKey -> ByteString -> Signature
|
actorKeySign :: ActorKey -> ByteString -> Signature
|
||||||
actorKeySign (ActorKey sec pub) = Signature . convert . sign sec pub
|
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.
|
{- 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.
|
- ♡ Copying is an act of love. Please copy, reuse and share.
|
||||||
-
|
-
|
||||||
|
@ -17,6 +17,7 @@ module Data.Tuple.Local
|
||||||
( fst3
|
( fst3
|
||||||
, fst4
|
, fst4
|
||||||
, fst5
|
, fst5
|
||||||
|
, fst6
|
||||||
, thd3
|
, thd3
|
||||||
, fourth4
|
, fourth4
|
||||||
, fourth5
|
, fourth5
|
||||||
|
@ -32,6 +33,9 @@ fst4 (x, _, _, _) = x
|
||||||
fst5 :: (a, b, c, d, e) -> a
|
fst5 :: (a, b, c, d, e) -> a
|
||||||
fst5 (x, _, _, _, _) = x
|
fst5 (x, _, _, _, _) = x
|
||||||
|
|
||||||
|
fst6 :: (a, b, c, d, e, f) -> a
|
||||||
|
fst6 (x, _, _, _, _, _) = x
|
||||||
|
|
||||||
thd3 :: (a, b, c) -> c
|
thd3 :: (a, b, c) -> c
|
||||||
thd3 (_, _, z) = z
|
thd3 (_, _, z) = z
|
||||||
|
|
||||||
|
|
|
@ -1,6 +1,6 @@
|
||||||
{- This file is part of Vervis.
|
{- 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.
|
- ♡ Copying is an act of love. Please copy, reuse and share.
|
||||||
-
|
-
|
||||||
|
@ -35,6 +35,7 @@ module Network.FedURI
|
||||||
, PageURI (..)
|
, PageURI (..)
|
||||||
, RefURI (..)
|
, RefURI (..)
|
||||||
, parseRefURI
|
, parseRefURI
|
||||||
|
, renderRefURI
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
|
@ -570,6 +571,9 @@ parseRefURI = toRefURI <=< toFullRefURI <=< parseFullURI
|
||||||
uriFromRefURI :: UriMode t => RefURI t -> URI
|
uriFromRefURI :: UriMode t => RefURI t -> URI
|
||||||
uriFromRefURI = fromFullURI . fromFullRefURI . fromRefURI
|
uriFromRefURI = fromFullURI . fromFullRefURI . fromRefURI
|
||||||
|
|
||||||
|
renderRefURI :: UriMode t => RefURI t -> Text
|
||||||
|
renderRefURI = renderFullURI . fromFullRefURI . fromRefURI
|
||||||
|
|
||||||
instance UriMode t => FromJSON (RefURI t) where
|
instance UriMode t => FromJSON (RefURI t) where
|
||||||
parseJSON = either fail return . toRefURI <=< parseJSON
|
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 Yesod.Mail.Send (runMailer)
|
||||||
|
|
||||||
import Control.Concurrent.ResultShare
|
import Control.Concurrent.ResultShare
|
||||||
|
import Crypto.ActorKey
|
||||||
import Data.KeyFile
|
import Data.KeyFile
|
||||||
|
import Development.PatchMediaType
|
||||||
import Network.FedURI
|
import Network.FedURI
|
||||||
import Yesod.Hashids
|
import Yesod.Hashids
|
||||||
import Yesod.MonadSite
|
import Yesod.MonadSite
|
||||||
|
@ -92,9 +94,8 @@ import Control.Concurrent.Local
|
||||||
import Data.List.NonEmpty.Local
|
import Data.List.NonEmpty.Local
|
||||||
import Web.Hashids.Local
|
import Web.Hashids.Local
|
||||||
|
|
||||||
import Vervis.ActorKey (generateActorKey, actorKeyRotator)
|
|
||||||
import Vervis.Darcs
|
import Vervis.Darcs
|
||||||
import Vervis.Delivery
|
import Vervis.Web.Delivery
|
||||||
import Vervis.Foundation
|
import Vervis.Foundation
|
||||||
import Vervis.Git
|
import Vervis.Git
|
||||||
import Vervis.Hook
|
import Vervis.Hook
|
||||||
|
@ -122,8 +123,8 @@ import Vervis.Handler.Ticket
|
||||||
import Vervis.Migration (migrateDB)
|
import Vervis.Migration (migrateDB)
|
||||||
import Vervis.Model
|
import Vervis.Model
|
||||||
import Vervis.Model.Ident
|
import Vervis.Model.Ident
|
||||||
import Development.PatchMediaType
|
|
||||||
import Vervis.Path
|
import Vervis.Path
|
||||||
|
import Vervis.Persist.Actor
|
||||||
import Vervis.Settings
|
import Vervis.Settings
|
||||||
import Vervis.Ssh (runSsh)
|
import Vervis.Ssh (runSsh)
|
||||||
|
|
||||||
|
@ -160,8 +161,14 @@ makeFoundation appSettings = do
|
||||||
else loadFont "data/LinLibertineCut.svg"
|
else loadFont "data/LinLibertineCut.svg"
|
||||||
|
|
||||||
appActorKeys <-
|
appActorKeys <-
|
||||||
newTVarIO =<<
|
if appPerActorKeys appSettings
|
||||||
(,,) <$> generateActorKey <*> generateActorKey <*> pure True
|
then pure Nothing
|
||||||
|
else Just <$> do
|
||||||
|
keys <- (,,)
|
||||||
|
<$> generateActorKey
|
||||||
|
<*> generateActorKey
|
||||||
|
<*> pure True
|
||||||
|
newTVarIO keys
|
||||||
|
|
||||||
appInstanceMutex <- newInstanceMutex
|
appInstanceMutex <- newInstanceMutex
|
||||||
|
|
||||||
|
@ -346,9 +353,9 @@ getAppSettings = loadYamlSettings [configSettingsYml] [] useEnv
|
||||||
develMain :: IO ()
|
develMain :: IO ()
|
||||||
develMain = develMainHelper getApplicationDev
|
develMain = develMainHelper getApplicationDev
|
||||||
|
|
||||||
actorKeyPeriodicRotator :: App -> IO ()
|
actorKeyPeriodicRotator :: App -> Maybe (IO ())
|
||||||
actorKeyPeriodicRotator app =
|
actorKeyPeriodicRotator app =
|
||||||
actorKeyRotator (appActorKeyRotation $ appSettings app) (appActorKeys app)
|
actorKeyRotator (appActorKeyRotation $ appSettings app) <$> appActorKeys app
|
||||||
|
|
||||||
deliveryRunner :: App -> IO ()
|
deliveryRunner :: App -> IO ()
|
||||||
deliveryRunner app =
|
deliveryRunner app =
|
||||||
|
@ -399,7 +406,11 @@ appMain = do
|
||||||
app <- makeApplication foundation
|
app <- makeApplication foundation
|
||||||
|
|
||||||
-- Run actor signature key periodic generation thread
|
-- 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
|
-- Run periodic activity delivery retry runner
|
||||||
when (appFederation $ appSettings foundation) $
|
when (appFederation $ appSettings foundation) $
|
||||||
|
|
|
@ -14,7 +14,9 @@
|
||||||
-}
|
-}
|
||||||
|
|
||||||
module Vervis.Client
|
module Vervis.Client
|
||||||
( --createThread
|
( makeServerInput
|
||||||
|
|
||||||
|
--, createThread
|
||||||
--, createReply
|
--, createReply
|
||||||
--, follow
|
--, follow
|
||||||
--, followSharer
|
--, followSharer
|
||||||
|
@ -28,7 +30,7 @@ module Vervis.Client
|
||||||
--, undoFollowTicket
|
--, undoFollowTicket
|
||||||
--, undoFollowRepo
|
--, undoFollowRepo
|
||||||
--, unresolve
|
--, unresolve
|
||||||
offerPatches
|
, offerPatches
|
||||||
, offerMerge
|
, offerMerge
|
||||||
, applyPatches
|
, applyPatches
|
||||||
, createDeck
|
, createDeck
|
||||||
|
@ -85,6 +87,31 @@ import Vervis.RemoteActorStore
|
||||||
import Vervis.Ticket
|
import Vervis.Ticket
|
||||||
import Vervis.WorkItem
|
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
|
createThread
|
||||||
:: (MonadSite m, SiteEnv m ~ App)
|
:: (MonadSite m, SiteEnv m ~ App)
|
||||||
|
@ -547,7 +574,7 @@ offerPatches
|
||||||
-> Maybe Text
|
-> Maybe Text
|
||||||
-> PatchMediaType
|
-> PatchMediaType
|
||||||
-> NonEmpty Text
|
-> 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
|
offerPatches senderHash title desc uTracker uTargetRepo maybeBranch typ diffs = do
|
||||||
|
|
||||||
tracker <- do
|
tracker <- do
|
||||||
|
@ -567,7 +594,6 @@ offerPatches senderHash title desc uTracker uTargetRepo maybeBranch typ diffs =
|
||||||
descHtml <- ExceptT . pure $ renderPandocMarkdown desc
|
descHtml <- ExceptT . pure $ renderPandocMarkdown desc
|
||||||
|
|
||||||
encodeRouteLocal <- getEncodeRouteLocal
|
encodeRouteLocal <- getEncodeRouteLocal
|
||||||
encodeRouteHome <- getEncodeRouteHome
|
|
||||||
hLocal <- asksSite siteInstanceHost
|
hLocal <- asksSite siteInstanceHost
|
||||||
|
|
||||||
let audAuthor =
|
let audAuthor =
|
||||||
|
@ -583,10 +609,7 @@ offerPatches senderHash title desc uTracker uTargetRepo maybeBranch typ diffs =
|
||||||
[luTracker]
|
[luTracker]
|
||||||
(maybeToList $ remoteActorFollowers remoteActor)
|
(maybeToList $ remoteActorFollowers remoteActor)
|
||||||
|
|
||||||
|
audience = [audAuthor, audTracker]
|
||||||
(_, _, _, audLocal, audRemote) =
|
|
||||||
collectAudience [audAuthor, audTracker]
|
|
||||||
recips = map encodeRouteHome audLocal ++ audRemote
|
|
||||||
|
|
||||||
luSender = encodeRouteLocal $ PersonR senderHash
|
luSender = encodeRouteLocal $ PersonR senderHash
|
||||||
ObjURI hTargetRepo luTargetRepo = uTargetRepo
|
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
|
offerMerge
|
||||||
:: KeyHashid Person
|
:: KeyHashid Person
|
||||||
|
@ -641,7 +664,7 @@ offerMerge
|
||||||
-> Maybe Text
|
-> Maybe Text
|
||||||
-> FedURI
|
-> FedURI
|
||||||
-> Maybe Text
|
-> 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
|
offerMerge senderHash title desc uTracker uTargetRepo maybeTargetBranch uOriginRepo maybeOriginBranch = do
|
||||||
|
|
||||||
tracker <- do
|
tracker <- do
|
||||||
|
@ -661,7 +684,6 @@ offerMerge senderHash title desc uTracker uTargetRepo maybeTargetBranch uOriginR
|
||||||
descHtml <- ExceptT . pure $ renderPandocMarkdown desc
|
descHtml <- ExceptT . pure $ renderPandocMarkdown desc
|
||||||
|
|
||||||
encodeRouteLocal <- getEncodeRouteLocal
|
encodeRouteLocal <- getEncodeRouteLocal
|
||||||
encodeRouteHome <- getEncodeRouteHome
|
|
||||||
hLocal <- asksSite siteInstanceHost
|
hLocal <- asksSite siteInstanceHost
|
||||||
|
|
||||||
let audAuthor =
|
let audAuthor =
|
||||||
|
@ -677,10 +699,7 @@ offerMerge senderHash title desc uTracker uTargetRepo maybeTargetBranch uOriginR
|
||||||
[luTracker]
|
[luTracker]
|
||||||
(maybeToList $ remoteActorFollowers remoteActor)
|
(maybeToList $ remoteActorFollowers remoteActor)
|
||||||
|
|
||||||
|
audience = [audAuthor, audTracker]
|
||||||
(_, _, _, audLocal, audRemote) =
|
|
||||||
collectAudience [audAuthor, audTracker]
|
|
||||||
recips = map encodeRouteHome audLocal ++ audRemote
|
|
||||||
|
|
||||||
ObjURI hTargetRepo luTargetRepo = uTargetRepo
|
ObjURI hTargetRepo luTargetRepo = uTargetRepo
|
||||||
ObjURI hOriginRepo luOriginRepo = uOriginRepo
|
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
|
applyPatches
|
||||||
:: KeyHashid Person
|
:: KeyHashid Person
|
||||||
-> FedURI
|
-> FedURI
|
||||||
-> ExceptT Text Handler (Maybe HTML, Audience URIMode, Apply URIMode)
|
-> ExceptT Text Handler (Maybe HTML, [Aud URIMode], Apply URIMode)
|
||||||
applyPatches senderHash uObject = do
|
applyPatches senderHash uObject = do
|
||||||
|
|
||||||
bundle <- parseProposalBundle "Apply object" uObject
|
bundle <- parseProposalBundle "Apply object" uObject
|
||||||
|
@ -818,27 +837,21 @@ applyPatches senderHash uObject = do
|
||||||
[luTracker]
|
[luTracker]
|
||||||
(catMaybes [mluFollowers, Just luTicketFollowers])
|
(catMaybes [mluFollowers, Just luTicketFollowers])
|
||||||
|
|
||||||
(_, _, _, audLocal, audRemote) = collectAudience [audAuthor, audCloth]
|
audience = [audAuthor, audCloth]
|
||||||
|
|
||||||
recips = map encodeRouteHome audLocal ++ audRemote
|
return (Nothing, audience, Apply uObject target)
|
||||||
|
|
||||||
return (Nothing, Audience recips [] [] [] [] [], Apply uObject target)
|
|
||||||
|
|
||||||
createDeck
|
createDeck
|
||||||
:: (MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App)
|
:: (MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App)
|
||||||
=> KeyHashid Person
|
=> KeyHashid Person
|
||||||
-> Text
|
-> Text
|
||||||
-> Text
|
-> Text
|
||||||
-> m (Maybe HTML, Audience URIMode, AP.ActorDetail)
|
-> m (Maybe HTML, [Aud URIMode], AP.ActorDetail)
|
||||||
createDeck senderHash name desc = do
|
createDeck senderHash name desc = do
|
||||||
encodeRouteHome <- getEncodeRouteHome
|
|
||||||
|
|
||||||
let audAuthor =
|
let audAuthor =
|
||||||
AudLocal [] [LocalStagePersonFollowers senderHash]
|
AudLocal [] [LocalStagePersonFollowers senderHash]
|
||||||
|
|
||||||
(_, _, _, audLocal, audRemote) = collectAudience [audAuthor]
|
audience = [audAuthor]
|
||||||
|
|
||||||
recips = map encodeRouteHome audLocal ++ audRemote
|
|
||||||
|
|
||||||
detail = AP.ActorDetail
|
detail = AP.ActorDetail
|
||||||
{ AP.actorType = AP.ActorTypeTicketTracker
|
{ AP.actorType = AP.ActorTypeTicketTracker
|
||||||
|
@ -847,7 +860,7 @@ createDeck senderHash name desc = do
|
||||||
, AP.actorSummary = Just desc
|
, AP.actorSummary = Just desc
|
||||||
}
|
}
|
||||||
|
|
||||||
return (Nothing, AP.Audience recips [] [] [] [] [], detail)
|
return (Nothing, audience, detail)
|
||||||
|
|
||||||
createLoom
|
createLoom
|
||||||
:: (MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App)
|
:: (MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App)
|
||||||
|
@ -855,7 +868,7 @@ createLoom
|
||||||
-> Text
|
-> Text
|
||||||
-> Text
|
-> Text
|
||||||
-> KeyHashid Repo
|
-> 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
|
createLoom senderHash name desc repoHash = do
|
||||||
encodeRouteHome <- getEncodeRouteHome
|
encodeRouteHome <- getEncodeRouteHome
|
||||||
|
|
||||||
|
@ -866,9 +879,7 @@ createLoom senderHash name desc repoHash = do
|
||||||
[LocalActorRepo repoHash]
|
[LocalActorRepo repoHash]
|
||||||
[LocalStageRepoFollowers repoHash]
|
[LocalStageRepoFollowers repoHash]
|
||||||
|
|
||||||
(_, _, _, audLocal, audRemote) = collectAudience [audAuthor, audRepo]
|
audience = [audAuthor, audRepo]
|
||||||
|
|
||||||
recips = map encodeRouteHome audLocal ++ audRemote
|
|
||||||
|
|
||||||
detail = AP.ActorDetail
|
detail = AP.ActorDetail
|
||||||
{ AP.actorType = AP.ActorTypePatchTracker
|
{ AP.actorType = AP.ActorTypePatchTracker
|
||||||
|
@ -878,23 +889,19 @@ createLoom senderHash name desc repoHash = do
|
||||||
}
|
}
|
||||||
repo = encodeRouteHome $ RepoR repoHash
|
repo = encodeRouteHome $ RepoR repoHash
|
||||||
|
|
||||||
return (Nothing, AP.Audience recips [] [] [] [] [], detail, repo :| [])
|
return (Nothing, audience, detail, repo :| [])
|
||||||
|
|
||||||
createRepo
|
createRepo
|
||||||
:: (MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App)
|
:: (MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App)
|
||||||
=> KeyHashid Person
|
=> KeyHashid Person
|
||||||
-> Text
|
-> Text
|
||||||
-> Text
|
-> Text
|
||||||
-> m (Maybe HTML, Audience URIMode, AP.ActorDetail)
|
-> m (Maybe HTML, [Aud URIMode], AP.ActorDetail)
|
||||||
createRepo senderHash name desc = do
|
createRepo senderHash name desc = do
|
||||||
encodeRouteHome <- getEncodeRouteHome
|
|
||||||
|
|
||||||
let audAuthor =
|
let audAuthor =
|
||||||
AudLocal [] [LocalStagePersonFollowers senderHash]
|
AudLocal [] [LocalStagePersonFollowers senderHash]
|
||||||
|
|
||||||
(_, _, _, audLocal, audRemote) = collectAudience [audAuthor]
|
audience = [audAuthor]
|
||||||
|
|
||||||
recips = map encodeRouteHome audLocal ++ audRemote
|
|
||||||
|
|
||||||
detail = AP.ActorDetail
|
detail = AP.ActorDetail
|
||||||
{ AP.actorType = AP.ActorTypeRepo
|
{ AP.actorType = AP.ActorTypeRepo
|
||||||
|
@ -903,4 +910,4 @@ createRepo senderHash name desc = do
|
||||||
, AP.actorSummary = Just desc
|
, AP.actorSummary = Just desc
|
||||||
}
|
}
|
||||||
|
|
||||||
return (Nothing, AP.Audience recips [] [] [] [] [], detail)
|
return (Nothing, audience, detail)
|
||||||
|
|
|
@ -17,6 +17,8 @@ module Vervis.Data.Actor
|
||||||
( parseLocalActivityURI
|
( parseLocalActivityURI
|
||||||
, parseActivityURI
|
, parseActivityURI
|
||||||
, activityRoute
|
, activityRoute
|
||||||
|
, stampRoute
|
||||||
|
, parseStampRoute
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
|
@ -80,3 +82,17 @@ activityRoute (LocalActorGroup g) = GroupOutboxItemR g
|
||||||
activityRoute (LocalActorRepo r) = RepoOutboxItemR r
|
activityRoute (LocalActorRepo r) = RepoOutboxItemR r
|
||||||
activityRoute (LocalActorDeck d) = DeckOutboxItemR d
|
activityRoute (LocalActorDeck d) = DeckOutboxItemR d
|
||||||
activityRoute (LocalActorLoom l) = LoomOutboxItemR l
|
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.ActivityPub
|
||||||
import Vervis.ActorKey
|
import Vervis.ActorKey
|
||||||
import Vervis.Delivery
|
import Vervis.Web.Delivery
|
||||||
import Vervis.Federation.Auth
|
import Vervis.Federation.Auth
|
||||||
import Vervis.Foundation
|
import Vervis.Foundation
|
||||||
import Vervis.Model
|
import Vervis.Model
|
||||||
|
|
|
@ -72,6 +72,7 @@ import Data.Time.Interval
|
||||||
import Network.HTTP.Signature hiding (requestHeaders)
|
import Network.HTTP.Signature hiding (requestHeaders)
|
||||||
import Yesod.HttpSignature
|
import Yesod.HttpSignature
|
||||||
|
|
||||||
|
import Crypto.ActorKey
|
||||||
import Crypto.PublicVerifKey
|
import Crypto.PublicVerifKey
|
||||||
import Database.Persist.JSON
|
import Database.Persist.JSON
|
||||||
import Network.FedURI
|
import Network.FedURI
|
||||||
|
@ -94,7 +95,7 @@ import Database.Persist.Local
|
||||||
import Yesod.Persist.Local
|
import Yesod.Persist.Local
|
||||||
|
|
||||||
import Vervis.ActivityPub
|
import Vervis.ActivityPub
|
||||||
import Vervis.ActorKey
|
import Vervis.Data.Actor
|
||||||
import Vervis.FedURI
|
import Vervis.FedURI
|
||||||
import Vervis.Foundation
|
import Vervis.Foundation
|
||||||
import Vervis.Model
|
import Vervis.Model
|
||||||
|
@ -261,21 +262,14 @@ verifyActorSig (Verification malgo keyid input signature) = do
|
||||||
Right lu
|
Right lu
|
||||||
_ -> throwE "Multiple ActivityPub-Actor headers"
|
_ -> throwE "Multiple ActivityPub-Actor headers"
|
||||||
|
|
||||||
verifySelfSig
|
verifySelfSigIK
|
||||||
:: LocalURI
|
:: TVar (ActorKey, ActorKey, Bool)
|
||||||
|
-> LocalActorBy Key
|
||||||
-> LocalRefURI
|
-> LocalRefURI
|
||||||
-> ByteString
|
-> ByteString
|
||||||
-> Signature
|
-> Signature
|
||||||
-> ExceptT String Handler (LocalActorBy Key)
|
-> ExceptT String Handler ()
|
||||||
verifySelfSig luAuthor (LocalRefURI lruKey) input (Signature sig) = do
|
verifySelfSigIK instanceKeys authorByKey (LocalRefURI lruKey) input 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"
|
|
||||||
akey <- do
|
akey <- do
|
||||||
route <- do
|
route <- do
|
||||||
luKey <-
|
luKey <-
|
||||||
|
@ -285,34 +279,82 @@ verifySelfSig luAuthor (LocalRefURI lruKey) input (Signature sig) = do
|
||||||
fromMaybeE
|
fromMaybeE
|
||||||
(decodeRouteLocal luKey)
|
(decodeRouteLocal luKey)
|
||||||
"Local key ID isn't a valid route"
|
"Local key ID isn't a valid route"
|
||||||
(akey1, akey2, _) <- liftIO . readTVarIO =<< getsYesod appActorKeys
|
(akey1, akey2, _) <- liftIO $ readTVarIO instanceKeys
|
||||||
case route of
|
case route of
|
||||||
ActorKey1R -> return akey1
|
ActorKey1R -> return akey1
|
||||||
ActorKey2R -> return akey2
|
ActorKey2R -> return akey2
|
||||||
_ -> throwE "Local key ID isn't an actor key route"
|
_ -> throwE "Local key ID isn't an instance key route"
|
||||||
valid <-
|
valid <- ExceptT . pure $ actorKeyVerify akey input sig
|
||||||
ExceptT . pure $ verifySignature (actorKeyPublicBin akey) input sig
|
|
||||||
unless valid $
|
unless valid $
|
||||||
throwE "Self sig verification says not valid"
|
throwE "Self sig verification says not valid"
|
||||||
localAuth <- unhashLocalActorE author "No such actor"
|
withExceptT T.unpack $ runDBExcept $ findLocalAuthInDB authorByKey
|
||||||
withExceptT T.unpack $ runDBExcept $ findLocalAuthInDB localAuth
|
|
||||||
return localAuth
|
|
||||||
where
|
where
|
||||||
findLocalAuthInDB (LocalActorPerson pid) = do
|
findLocalAuthInDB actor = do
|
||||||
mp <- lift $ get pid
|
ma <- lift $ getLocalActorID actor
|
||||||
when (isNothing mp) $ throwE "No such person"
|
when (isNothing ma) $ throwE "No such actor in DB"
|
||||||
findLocalAuthInDB (LocalActorGroup gid) = do
|
|
||||||
mg <- lift $ get gid
|
verifySelfSigAK
|
||||||
when (isNothing mg) $ throwE "No such group"
|
:: LocalActorBy Key
|
||||||
findLocalAuthInDB (LocalActorRepo rid) = do
|
-> LocalRefURI
|
||||||
mr <- lift $ get rid
|
-> ByteString
|
||||||
when (isNothing mr) $ throwE "No such repo"
|
-> Signature
|
||||||
findLocalAuthInDB (LocalActorDeck did) = do
|
-> ExceptT String Handler ()
|
||||||
md <- lift $ get did
|
verifySelfSigAK authorByKey (LocalRefURI lruKey) input sig = do
|
||||||
when (isNothing md) $ throwE "No such deck"
|
keyID <- do
|
||||||
findLocalAuthInDB (LocalActorLoom lid) = do
|
luKey <-
|
||||||
ml <- lift $ get lid
|
case lruKey of
|
||||||
when (isNothing ml) $ throwE "No such loom"
|
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
|
verifyForwardedSig
|
||||||
:: Host
|
:: Host
|
||||||
|
|
|
@ -73,7 +73,7 @@ import Vervis.Access
|
||||||
import Vervis.ActivityPub
|
import Vervis.ActivityPub
|
||||||
import Vervis.Data.Actor
|
import Vervis.Data.Actor
|
||||||
import Vervis.Data.Collab
|
import Vervis.Data.Collab
|
||||||
import Vervis.Delivery
|
import Vervis.Web.Delivery
|
||||||
import Vervis.FedURI
|
import Vervis.FedURI
|
||||||
import Vervis.Federation.Auth
|
import Vervis.Federation.Auth
|
||||||
import Vervis.Federation.Util
|
import Vervis.Federation.Util
|
||||||
|
@ -163,22 +163,18 @@ personInviteF now recipHash author body mfwd luInvite invite = (,Nothing) <$> do
|
||||||
if inviteeIsRecip
|
if inviteeIsRecip
|
||||||
then makeRecipientSet [] [LocalStagePersonFollowers recipHash]
|
then makeRecipientSet [] [LocalStagePersonFollowers recipHash]
|
||||||
else makeRecipientSet [] []
|
else makeRecipientSet [] []
|
||||||
remoteRecips <-
|
forwardActivityDB
|
||||||
insertRemoteActivityToLocalInboxes
|
(actbBL body) localRecips sig (personActor personRecip)
|
||||||
False inviteID $
|
(LocalActorPerson recipHash) sieve inviteID
|
||||||
localRecipSieve'
|
|
||||||
sieve False False localRecips
|
|
||||||
(sig,) <$> deliverRemoteDB_P (actbBL body) inviteID personRecipID sig remoteRecips
|
|
||||||
|
|
||||||
-- Launch asynchronous HTTP forwarding of the Invite activity
|
-- Launch asynchronous HTTP forwarding of the Invite activity
|
||||||
case mhttp of
|
case mhttp of
|
||||||
Nothing -> return "I already have this activity in my inbox, doing nothing"
|
Nothing -> return "I already have this activity in my inbox, doing nothing"
|
||||||
Just mremotesHttpFwd -> do
|
Just maybeForwardHttpInvite -> do
|
||||||
for_ mremotesHttpFwd $ \ (sig, remotes) ->
|
for_ maybeForwardHttpInvite $
|
||||||
forkWorker "personInviteF inbox-forwarding" $
|
forkWorker "personInviteF inbox-forwarding"
|
||||||
deliverRemoteHTTP_P now recipHash (actbBL body) sig remotes
|
|
||||||
return $
|
return $
|
||||||
case mremotesHttpFwd of
|
case maybeForwardHttpInvite of
|
||||||
Nothing -> "Inserted to inbox, no inbox-forwarding to do"
|
Nothing -> "Inserted to inbox, no inbox-forwarding to do"
|
||||||
Just _ -> "Inserted to inbox and ran inbox-forwarding of the Invite"
|
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
|
-- and schedule delivery for unavailable remote members of
|
||||||
-- them
|
-- them
|
||||||
for mfwd $ \ (localRecips, sig) -> do
|
for mfwd $ \ (localRecips, sig) -> do
|
||||||
let sieve =
|
let recipLocalActor =
|
||||||
makeRecipientSet [] [localActorFollowers $ grantResourceLocalActor recipByHash]
|
grantResourceLocalActor recipByHash
|
||||||
remoteRecips <-
|
sieve =
|
||||||
insertRemoteActivityToLocalInboxes
|
makeRecipientSet [] [localActorFollowers recipLocalActor]
|
||||||
False inviteID $
|
forwardActivityDB
|
||||||
localRecipSieve'
|
(actbBL body) localRecips sig recipActorID
|
||||||
sieve False False localRecips
|
recipLocalActor sieve inviteID
|
||||||
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
|
|
||||||
|
|
||||||
-- Launch asynchronous HTTP forwarding of the Invite activity
|
-- Launch asynchronous HTTP forwarding of the Invite activity
|
||||||
case mhttp of
|
case mhttp of
|
||||||
|
@ -335,21 +318,6 @@ topicAcceptF
|
||||||
:: (PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic)
|
:: (PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic)
|
||||||
=> (topic -> ActorId)
|
=> (topic -> ActorId)
|
||||||
-> (forall f. f topic -> GrantResourceBy f)
|
-> (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
|
-> UTCTime
|
||||||
-> KeyHashid topic
|
-> KeyHashid topic
|
||||||
-> RemoteAuthor
|
-> RemoteAuthor
|
||||||
|
@ -358,7 +326,7 @@ topicAcceptF
|
||||||
-> LocalURI
|
-> LocalURI
|
||||||
-> AP.Accept URIMode
|
-> AP.Accept URIMode
|
||||||
-> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
|
-> 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
|
-- Check input
|
||||||
acceptee <- parseAccept accept
|
acceptee <- parseAccept accept
|
||||||
|
@ -428,74 +396,54 @@ topicAcceptF topicActor topicResource deliverRemoteDB deliverRemoteHTTP now reci
|
||||||
|
|
||||||
-- Forward the Accept activity to relevant local stages, and
|
-- Forward the Accept activity to relevant local stages, and
|
||||||
-- schedule delivery for unavailable remote members of them
|
-- 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 =
|
let sieve =
|
||||||
makeRecipientSet [] [localActorFollowers $ grantResourceLocalActor $ topicResource recipHash]
|
makeRecipientSet [] [localActorFollowers recipByHash]
|
||||||
remoteRecips <-
|
forwardActivityDB
|
||||||
insertRemoteActivityToLocalInboxes
|
(actbBL body) localRecips sig recipActorID recipByHash
|
||||||
False acceptID $
|
sieve acceptID
|
||||||
localRecipSieve'
|
|
||||||
sieve False False localRecips
|
|
||||||
(sig,) <$> deliverRemoteDB (actbBL body) acceptID recipKey sig remoteRecips
|
|
||||||
|
|
||||||
remotesHttpGrant <- lift $ do
|
deliverHttpGrant <- do
|
||||||
|
|
||||||
-- Enable the Collab in our DB
|
-- Enable the Collab in our DB
|
||||||
grantID <- insertEmptyOutboxItem (actorOutbox recipActor) now
|
grantID <- lift $ insertEmptyOutboxItem (actorOutbox recipActor) now
|
||||||
insert_ $ CollabEnable collabID grantID
|
lift $ insert_ $ CollabEnable collabID grantID
|
||||||
|
|
||||||
-- Prepare a Grant activity and insert to topic's outbox
|
-- Prepare a Grant activity and insert to topic's outbox
|
||||||
(docGrant, localRecipsGrant, remoteRecipsGrant, fwdHostsGrant) <-
|
(actionGrant, localRecipsGrant, remoteRecipsGrant, fwdHostsGrant) <-
|
||||||
insertGrantToOutbox inviteSender grantID
|
lift $ prepareGrant inviteSender
|
||||||
|
let recipByKey = grantResourceLocalActor $ topicResource recipKey
|
||||||
|
_luGrant <- lift $ updateOutboxItem recipByKey grantID actionGrant
|
||||||
|
|
||||||
-- Deliver the Grant to local recipients, and schedule delivery
|
-- Deliver the Grant to local recipients, and schedule delivery
|
||||||
-- for unavailable remote recipients
|
-- for unavailable remote recipients
|
||||||
(grantID, docGrant, fwdHostsGrant,) <$> do
|
deliverActivityDB
|
||||||
knownRemoteRecipsGrant <-
|
recipByHash recipActorID localRecipsGrant remoteRecipsGrant
|
||||||
deliverLocal'
|
fwdHostsGrant grantID actionGrant
|
||||||
False
|
|
||||||
(grantResourceLocalActor $ topicResource recipHash)
|
|
||||||
recipActorID
|
|
||||||
grantID
|
|
||||||
localRecipsGrant
|
|
||||||
deliverRemoteDB'' fwdHostsGrant grantID remoteRecipsGrant knownRemoteRecipsGrant
|
|
||||||
|
|
||||||
return (maybeRemotesHttpFwdAccept, remotesHttpGrant)
|
return (maybeHttpFwdAccept, deliverHttpGrant)
|
||||||
|
|
||||||
-- Launch asynchronous HTTP forwarding of the Accept activity
|
-- Launch asynchronous HTTP forwarding of the Accept activity
|
||||||
case mhttp of
|
case mhttp of
|
||||||
Nothing -> return "I already have this activity in my inbox, doing nothing"
|
Nothing -> return "I already have this activity in my inbox, doing nothing"
|
||||||
Just (mremotesHttpFwd, (grantID, docGrant, fwdHostsGrant, recipsGrant)) -> do
|
Just (mhttpFwd, deliverHttpGrant) -> do
|
||||||
forkWorker "topicAcceptF Grant HTTP delivery" $
|
forkWorker "topicAcceptF Grant HTTP delivery" deliverHttpGrant
|
||||||
deliverRemoteHttp' fwdHostsGrant grantID docGrant recipsGrant
|
case mhttpFwd of
|
||||||
case mremotesHttpFwd of
|
|
||||||
Nothing -> return "Sent a Grant, no inbox-forwarding to do"
|
Nothing -> return "Sent a Grant, no inbox-forwarding to do"
|
||||||
Just (sig, remotes) -> do
|
Just forwardHttpAccept -> do
|
||||||
forkWorker "topicAcceptF inbox-forwarding" $
|
forkWorker "topicAcceptF inbox-forwarding" forwardHttpAccept
|
||||||
deliverRemoteHTTP now recipHash (actbBL body) sig remotes
|
|
||||||
return "Sent a Grant and ran inbox-forwarding of the Accept"
|
return "Sent a Grant and ran inbox-forwarding of the Accept"
|
||||||
|
|
||||||
where
|
where
|
||||||
|
|
||||||
insertGrantToOutbox
|
prepareGrant sender = do
|
||||||
:: 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
|
|
||||||
encodeRouteHome <- getEncodeRouteHome
|
encodeRouteHome <- getEncodeRouteHome
|
||||||
hLocal <- asksSite siteInstanceHost
|
|
||||||
|
|
||||||
accepter <- getJust $ remoteAuthorId author
|
accepter <- getJust $ remoteAuthorId author
|
||||||
let topicByHash = grantResourceLocalActor $ topicResource recipHash
|
let topicByHash = grantResourceLocalActor $ topicResource recipHash
|
||||||
|
|
||||||
senderHash <- bitraverse hashLocalActor pure sender
|
senderHash <- bitraverse hashLocalActor pure sender
|
||||||
grantHash <- encodeKeyHashid grantID
|
|
||||||
|
|
||||||
let audSender =
|
let audSender =
|
||||||
case senderHash of
|
case senderHash of
|
||||||
|
@ -511,22 +459,19 @@ topicAcceptF topicActor topicResource deliverRemoteDB deliverRemoteHTTP now reci
|
||||||
collectAudience [audSender, audRecip, audTopic]
|
collectAudience [audSender, audRecip, audTopic]
|
||||||
|
|
||||||
recips = map encodeRouteHome audLocal ++ audRemote
|
recips = map encodeRouteHome audLocal ++ audRemote
|
||||||
doc = AP.Doc hLocal AP.Activity
|
action = AP.Action
|
||||||
{ AP.activityId = Just $ encodeRouteLocal $ activityRoute topicByHash grantHash
|
{ AP.actionCapability = Nothing
|
||||||
, AP.activityActor = encodeRouteLocal $ renderLocalActor topicByHash
|
, AP.actionSummary = Nothing
|
||||||
, AP.activityCapability = Nothing
|
, AP.actionAudience = AP.Audience recips [] [] [] [] []
|
||||||
, AP.activitySummary = Nothing
|
, AP.actionFulfills = [AP.acceptObject accept]
|
||||||
, AP.activityAudience = AP.Audience recips [] [] [] [] []
|
, AP.actionSpecific = AP.GrantActivity AP.Grant
|
||||||
, AP.activityFulfills = [AP.acceptObject accept]
|
|
||||||
, AP.activitySpecific = AP.GrantActivity AP.Grant
|
|
||||||
{ AP.grantObject = Left AP.RoleAdmin
|
{ AP.grantObject = Left AP.RoleAdmin
|
||||||
, AP.grantContext = encodeRouteHome $ renderLocalActor topicByHash
|
, AP.grantContext = encodeRouteHome $ renderLocalActor topicByHash
|
||||||
, AP.grantTarget = remoteAuthorURI author
|
, AP.grantTarget = remoteAuthorURI author
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
update grantID [OutboxItemActivity =. persistJSONObjectFromDoc doc]
|
return (action, recipientSet, remoteActors, fwdHosts)
|
||||||
return (doc, recipientSet, remoteActors, fwdHosts)
|
|
||||||
|
|
||||||
repoAcceptF
|
repoAcceptF
|
||||||
:: UTCTime
|
:: UTCTime
|
||||||
|
@ -537,8 +482,7 @@ repoAcceptF
|
||||||
-> LocalURI
|
-> LocalURI
|
||||||
-> AP.Accept URIMode
|
-> AP.Accept URIMode
|
||||||
-> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
|
-> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
|
||||||
repoAcceptF =
|
repoAcceptF = topicAcceptF repoActor GrantResourceRepo
|
||||||
topicAcceptF repoActor GrantResourceRepo deliverRemoteDB_R deliverRemoteHTTP_R
|
|
||||||
|
|
||||||
deckAcceptF
|
deckAcceptF
|
||||||
:: UTCTime
|
:: UTCTime
|
||||||
|
@ -549,8 +493,7 @@ deckAcceptF
|
||||||
-> LocalURI
|
-> LocalURI
|
||||||
-> AP.Accept URIMode
|
-> AP.Accept URIMode
|
||||||
-> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
|
-> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
|
||||||
deckAcceptF =
|
deckAcceptF = topicAcceptF deckActor GrantResourceDeck
|
||||||
topicAcceptF deckActor GrantResourceDeck deliverRemoteDB_D deliverRemoteHTTP_D
|
|
||||||
|
|
||||||
loomAcceptF
|
loomAcceptF
|
||||||
:: UTCTime
|
:: UTCTime
|
||||||
|
@ -561,8 +504,7 @@ loomAcceptF
|
||||||
-> LocalURI
|
-> LocalURI
|
||||||
-> AP.Accept URIMode
|
-> AP.Accept URIMode
|
||||||
-> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
|
-> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
|
||||||
loomAcceptF =
|
loomAcceptF = topicAcceptF loomActor GrantResourceLoom
|
||||||
topicAcceptF loomActor GrantResourceLoom deliverRemoteDB_L deliverRemoteHTTP_L
|
|
||||||
|
|
||||||
personGrantF
|
personGrantF
|
||||||
:: UTCTime
|
:: UTCTime
|
||||||
|
@ -616,21 +558,16 @@ personGrantF now recipHash author body mfwd luGrant grant = (,Nothing) <$> do
|
||||||
if targetIsRecip
|
if targetIsRecip
|
||||||
then makeRecipientSet [] [LocalStagePersonFollowers recipHash]
|
then makeRecipientSet [] [LocalStagePersonFollowers recipHash]
|
||||||
else makeRecipientSet [] []
|
else makeRecipientSet [] []
|
||||||
remoteRecips <-
|
forwardActivityDB
|
||||||
insertRemoteActivityToLocalInboxes
|
(actbBL body) localRecips sig (personActor personRecip)
|
||||||
False grantID $
|
(LocalActorPerson recipHash) sieve grantID
|
||||||
localRecipSieve'
|
|
||||||
sieve False False localRecips
|
|
||||||
(sig,) <$> deliverRemoteDB_P (actbBL body) grantID personRecipID sig remoteRecips
|
|
||||||
|
|
||||||
-- Launch asynchronous HTTP forwarding of the Invite activity
|
-- Launch asynchronous HTTP forwarding of the Grant activity
|
||||||
case mhttp of
|
case mhttp of
|
||||||
Nothing -> return "I already have this activity in my inbox, doing nothing"
|
Nothing -> return "I already have this activity in my inbox, doing nothing"
|
||||||
Just mremotesHttpFwd -> do
|
Just mhttpFwd -> do
|
||||||
for_ mremotesHttpFwd $ \ (sig, remotes) ->
|
for_ mhttpFwd $ forkWorker "personGrantF inbox-forwarding"
|
||||||
forkWorker "personGrantF inbox-forwarding" $
|
|
||||||
deliverRemoteHTTP_P now recipHash (actbBL body) sig remotes
|
|
||||||
return $
|
return $
|
||||||
case mremotesHttpFwd of
|
case mhttpFwd of
|
||||||
Nothing -> "Inserted to inbox, no inbox-forwarding to do"
|
Nothing -> "Inserted to inbox, no inbox-forwarding to do"
|
||||||
Just _ -> "Inserted to inbox and ran inbox-forwarding of the Grant"
|
Just _ -> "Inserted to inbox and ran inbox-forwarding of the Grant"
|
||||||
|
|
|
@ -344,7 +344,7 @@ followF
|
||||||
iidAuthor = remoteAuthorInstance author
|
iidAuthor = remoteAuthorInstance author
|
||||||
hAuthor = objUriAuthority $ remoteAuthorURI author
|
hAuthor = objUriAuthority $ remoteAuthorURI author
|
||||||
hostSection = ((iidAuthor, hAuthor), raInfo :| [])
|
hostSection = ((iidAuthor, hAuthor), raInfo :| [])
|
||||||
(obiid, doc,) <$> deliverRemoteDB'' [] obiid [] [hostSection]
|
(obiid, doc,) <$> deliverRemoteDB [] obiid [] [hostSection]
|
||||||
else do
|
else do
|
||||||
delete obiid
|
delete obiid
|
||||||
return $ Left "You're already a follower of me"
|
return $ Left "You're already a follower of me"
|
||||||
|
@ -698,7 +698,7 @@ sharerUndoF recipHash now author body mfwd luUndo (Undo uObj) = do
|
||||||
obiidAccept
|
obiidAccept
|
||||||
localRecipsAccept
|
localRecipsAccept
|
||||||
(obiidAccept,docAccept,fwdHostsAccept,) <$>
|
(obiidAccept,docAccept,fwdHostsAccept,) <$>
|
||||||
deliverRemoteDB'' fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept
|
deliverRemoteDB fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept
|
||||||
return (result, mremotesHttpFwd, mremotesHttpAccept)
|
return (result, mremotesHttpFwd, mremotesHttpAccept)
|
||||||
case mmmhttp of
|
case mmmhttp of
|
||||||
Nothing -> return "Activity already in my inbox"
|
Nothing -> return "Activity already in my inbox"
|
||||||
|
@ -802,7 +802,7 @@ projectUndoF recipHash now author body mfwd luUndo (Undo uObj) = do
|
||||||
obiidAccept
|
obiidAccept
|
||||||
localRecipsAccept
|
localRecipsAccept
|
||||||
(obiidAccept,docAccept,fwdHostsAccept,) <$>
|
(obiidAccept,docAccept,fwdHostsAccept,) <$>
|
||||||
deliverRemoteDB'' fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept
|
deliverRemoteDB fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept
|
||||||
return (result, mremotesHttpFwd, mremotesHttpAccept)
|
return (result, mremotesHttpFwd, mremotesHttpAccept)
|
||||||
case mmmhttp of
|
case mmmhttp of
|
||||||
Nothing -> return "Activity already in my inbox"
|
Nothing -> return "Activity already in my inbox"
|
||||||
|
@ -900,7 +900,7 @@ repoUndoF recipHash now author body mfwd luUndo (Undo uObj) = do
|
||||||
obiidAccept
|
obiidAccept
|
||||||
localRecipsAccept
|
localRecipsAccept
|
||||||
(obiidAccept,docAccept,fwdHostsAccept,) <$>
|
(obiidAccept,docAccept,fwdHostsAccept,) <$>
|
||||||
deliverRemoteDB'' fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept
|
deliverRemoteDB fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept
|
||||||
return (result, mremotesHttpFwd, mremotesHttpAccept)
|
return (result, mremotesHttpFwd, mremotesHttpAccept)
|
||||||
case mmmhttp of
|
case mmmhttp of
|
||||||
Nothing -> return "Activity already in my inbox"
|
Nothing -> return "Activity already in my inbox"
|
||||||
|
|
|
@ -96,7 +96,7 @@ import Vervis.Cloth
|
||||||
import Vervis.Data.Actor
|
import Vervis.Data.Actor
|
||||||
import Vervis.Data.Ticket
|
import Vervis.Data.Ticket
|
||||||
import Vervis.Darcs
|
import Vervis.Darcs
|
||||||
import Vervis.Delivery
|
import Vervis.Web.Delivery
|
||||||
import Vervis.Federation.Auth
|
import Vervis.Federation.Auth
|
||||||
import Vervis.Federation.Util
|
import Vervis.Federation.Util
|
||||||
import Vervis.FedURI
|
import Vervis.FedURI
|
||||||
|
@ -107,6 +107,7 @@ import Vervis.Model
|
||||||
import Vervis.Model.Role
|
import Vervis.Model.Role
|
||||||
import Vervis.Model.Ticket
|
import Vervis.Model.Ticket
|
||||||
import Vervis.Path
|
import Vervis.Path
|
||||||
|
import Vervis.Persist.Actor
|
||||||
import Vervis.Persist.Ticket
|
import Vervis.Persist.Ticket
|
||||||
import Vervis.Query
|
import Vervis.Query
|
||||||
import Vervis.Recipient
|
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
|
-- Find recipient deck in DB, returning 404 if doesn't exist because we're
|
||||||
-- in the deck's inbox post handler
|
-- in the deck's inbox post handler
|
||||||
maybeHttp <- lift $ runDB $ do
|
maybeHttp <- runDBExcept $ do
|
||||||
(recipDeckActorID, recipDeckActor) <- do
|
(recipDeckActorID, recipDeckActor) <- lift $ do
|
||||||
deck <- get404 recipDeckID
|
deck <- get404 recipDeckID
|
||||||
let actorID = deckActor deck
|
let actorID = deckActor deck
|
||||||
(actorID,) <$> getJust actorID
|
(actorID,) <$> getJust actorID
|
||||||
|
|
||||||
-- Insert the Offer to deck's inbox
|
-- 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
|
for mractid $ \ offerID -> do
|
||||||
|
|
||||||
-- Forward the Offer activity to relevant local stages, and
|
-- Forward the Offer activity to relevant local stages, and
|
||||||
-- schedule delivery for unavailable remote members of them
|
-- schedule delivery for unavailable remote members of them
|
||||||
maybeHttpFwdOffer <- for mfwd $ \ (localRecips, sig) -> do
|
maybeHttpFwdOffer <- lift $ for mfwd $ \ (localRecips, sig) -> do
|
||||||
let sieve =
|
let sieve =
|
||||||
makeRecipientSet
|
makeRecipientSet
|
||||||
[]
|
[]
|
||||||
[LocalStageDeckFollowers recipDeckHash]
|
[LocalStageDeckFollowers recipDeckHash]
|
||||||
remoteRecips <-
|
forwardActivityDB
|
||||||
insertRemoteActivityToLocalInboxes False offerID $
|
(actbBL body) localRecips sig recipDeckActorID
|
||||||
localRecipSieve' sieve False False localRecips
|
(LocalActorDeck recipDeckHash) sieve offerID
|
||||||
remoteRecipsHttp <-
|
|
||||||
deliverRemoteDB_D
|
|
||||||
(actbBL body) offerID recipDeckID sig remoteRecips
|
|
||||||
return $
|
|
||||||
deliverRemoteHTTP_D
|
|
||||||
now recipDeckHash (actbBL body) sig remoteRecipsHttp
|
|
||||||
|
|
||||||
-- Insert the new ticket to our DB
|
-- Insert the new ticket to our DB
|
||||||
acceptID <- insertEmptyOutboxItem (actorOutbox recipDeckActor) now
|
acceptID <- lift $ insertEmptyOutboxItem (actorOutbox recipDeckActor) now
|
||||||
taskID <- insertTask now title desc source recipDeckID offerID acceptID
|
taskID <- lift $ insertTask now title desc source recipDeckID offerID acceptID
|
||||||
|
|
||||||
-- Prepare an Accept activity and insert to deck's outbox
|
-- Prepare an Accept activity and insert to deck's outbox
|
||||||
(docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
|
(actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
|
||||||
insertAcceptToOutbox taskID acceptID
|
lift $ prepareAccept taskID
|
||||||
|
_luAccept <- lift $ updateOutboxItem (LocalActorDeck recipDeckID) acceptID actionAccept
|
||||||
|
|
||||||
-- Deliver the Accept to local recipients, and schedule delivery
|
-- Deliver the Accept to local recipients, and schedule delivery
|
||||||
-- for unavailable remote recipients
|
-- for unavailable remote recipients
|
||||||
knownRemoteRecipsAccept <-
|
deliverHttpAccept <-
|
||||||
deliverLocal'
|
deliverActivityDB
|
||||||
False (LocalActorDeck recipDeckHash) recipDeckActorID
|
(LocalActorDeck recipDeckHash) recipDeckActorID
|
||||||
acceptID localRecipsAccept
|
localRecipsAccept remoteRecipsAccept fwdHostsAccept
|
||||||
remoteRecipsHttpAccept <-
|
acceptID actionAccept
|
||||||
deliverRemoteDB''
|
|
||||||
fwdHostsAccept acceptID remoteRecipsAccept
|
|
||||||
knownRemoteRecipsAccept
|
|
||||||
|
|
||||||
-- Return instructions for HTTP inbox-forwarding of the Offer
|
-- Return instructions for HTTP inbox-forwarding of the Offer
|
||||||
-- activity, and for HTTP delivery of the Accept activity to
|
-- activity, and for HTTP delivery of the Accept activity to
|
||||||
-- remote recipients
|
-- remote recipients
|
||||||
return
|
return (maybeHttpFwdOffer, deliverHttpAccept)
|
||||||
( maybeHttpFwdOffer
|
|
||||||
, deliverRemoteHttp'
|
|
||||||
fwdHostsAccept acceptID docAccept remoteRecipsHttpAccept
|
|
||||||
)
|
|
||||||
|
|
||||||
-- Launch asynchronous HTTP forwarding of the Offer activity and HTTP
|
-- Launch asynchronous HTTP forwarding of the Offer activity and HTTP
|
||||||
-- delivery of the Accept activity
|
-- delivery of the Accept activity
|
||||||
|
@ -448,22 +437,11 @@ deckOfferTicketF now recipDeckHash author body mfwd luOffer ticket uTarget = do
|
||||||
}
|
}
|
||||||
insert $ TicketDeck tid deckID
|
insert $ TicketDeck tid deckID
|
||||||
|
|
||||||
insertAcceptToOutbox
|
prepareAccept taskID = do
|
||||||
:: TicketDeckId
|
|
||||||
-> OutboxItemId
|
|
||||||
-> ReaderT SqlBackend Handler
|
|
||||||
( AP.Doc AP.Activity URIMode
|
|
||||||
, RecipientRoutes
|
|
||||||
, [(Host, NonEmpty LocalURI)]
|
|
||||||
, [Host]
|
|
||||||
)
|
|
||||||
insertAcceptToOutbox taskID acceptID = do
|
|
||||||
encodeRouteLocal <- getEncodeRouteLocal
|
encodeRouteLocal <- getEncodeRouteLocal
|
||||||
encodeRouteHome <- getEncodeRouteHome
|
encodeRouteHome <- getEncodeRouteHome
|
||||||
hLocal <- asksSite siteInstanceHost
|
|
||||||
|
|
||||||
taskHash <- encodeKeyHashid taskID
|
taskHash <- encodeKeyHashid taskID
|
||||||
acceptHash <- encodeKeyHashid acceptID
|
|
||||||
|
|
||||||
ra <- getJust $ remoteAuthorId author
|
ra <- getJust $ remoteAuthorId author
|
||||||
|
|
||||||
|
@ -479,26 +457,20 @@ deckOfferTicketF now recipDeckHash author body mfwd luOffer ticket uTarget = do
|
||||||
collectAudience [audSender, audTracker]
|
collectAudience [audSender, audTracker]
|
||||||
|
|
||||||
recips = map encodeRouteHome audLocal ++ audRemote
|
recips = map encodeRouteHome audLocal ++ audRemote
|
||||||
doc = AP.Doc hLocal AP.Activity
|
action = AP.Action
|
||||||
{ AP.activityId =
|
{ AP.actionCapability = Nothing
|
||||||
Just $ encodeRouteLocal $
|
, AP.actionSummary = Nothing
|
||||||
DeckOutboxItemR recipDeckHash acceptHash
|
, AP.actionAudience = AP.Audience recips [] [] [] [] []
|
||||||
, AP.activityActor =
|
, AP.actionFulfills = []
|
||||||
encodeRouteLocal $ DeckR recipDeckHash
|
, AP.actionSpecific = AP.AcceptActivity AP.Accept
|
||||||
, AP.activityCapability = Nothing
|
{ AP.acceptObject = ObjURI hAuthor luOffer
|
||||||
, AP.activitySummary = Nothing
|
, AP.acceptResult =
|
||||||
, AP.activityAudience = AP.Audience recips [] [] [] [] []
|
|
||||||
, AP.activityFulfills = []
|
|
||||||
, AP.activitySpecific = AP.AcceptActivity AP.Accept
|
|
||||||
{ acceptObject = ObjURI hAuthor luOffer
|
|
||||||
, acceptResult =
|
|
||||||
Just $ encodeRouteLocal $
|
Just $ encodeRouteLocal $
|
||||||
TicketR recipDeckHash taskHash
|
TicketR recipDeckHash taskHash
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
update acceptID [OutboxItemActivity =. persistJSONObjectFromDoc doc]
|
return (action, recipientSet, remoteActors, fwdHosts)
|
||||||
return (doc, recipientSet, remoteActors, fwdHosts)
|
|
||||||
|
|
||||||
activityAlreadyInInbox hAct luAct inboxID = fmap isJust . runMaybeT $ do
|
activityAlreadyInInbox hAct luAct inboxID = fmap isJust . runMaybeT $ do
|
||||||
instanceID <- MaybeT $ getKeyBy $ UniqueInstance hAct
|
instanceID <- MaybeT $ getKeyBy $ UniqueInstance hAct
|
||||||
|
@ -684,33 +656,28 @@ loomOfferTicketF now recipLoomHash author body mfwd luOffer ticket uTarget = do
|
||||||
return $ Right uClone
|
return $ Right uClone
|
||||||
return $ Right $ maybeOriginRepo
|
return $ Right $ maybeOriginRepo
|
||||||
|
|
||||||
maybeHttp <- lift $ runSiteDB $ do
|
maybeHttp <- runSiteDBExcept $ do
|
||||||
|
|
||||||
-- Insert the Offer to loom's inbox
|
-- 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
|
for mractid $ \ offerID -> do
|
||||||
|
|
||||||
-- Forward the Offer activity to relevant local stages, and
|
-- Forward the Offer activity to relevant local stages, and
|
||||||
-- schedule delivery for unavailable remote members of them
|
-- schedule delivery for unavailable remote members of them
|
||||||
maybeHttpFwdOffer <- for mfwd $ \ (localRecips, sig) -> do
|
maybeHttpFwdOffer <- lift $ for mfwd $ \ (localRecips, sig) -> do
|
||||||
let sieve =
|
let sieve =
|
||||||
makeRecipientSet
|
makeRecipientSet
|
||||||
[]
|
[]
|
||||||
[LocalStageLoomFollowers recipLoomHash]
|
[LocalStageLoomFollowers recipLoomHash]
|
||||||
remoteRecips <-
|
forwardActivityDB
|
||||||
insertRemoteActivityToLocalInboxes False offerID $
|
(actbBL body) localRecips sig
|
||||||
localRecipSieve' sieve False False localRecips
|
recipLoomActorID (LocalActorLoom recipLoomHash)
|
||||||
remoteRecipsHttp <-
|
sieve offerID
|
||||||
deliverRemoteDB_L
|
|
||||||
(actbBL body) offerID recipLoomID sig remoteRecips
|
|
||||||
return $
|
|
||||||
deliverRemoteHTTP_L
|
|
||||||
now recipLoomHash (actbBL body) sig remoteRecipsHttp
|
|
||||||
|
|
||||||
-- Insert the new ticket to our DB
|
-- Insert the new ticket to our DB
|
||||||
acceptID <- insertEmptyOutboxItem (actorOutbox recipLoomActor) now
|
acceptID <- lift $ insertEmptyOutboxItem (actorOutbox recipLoomActor) now
|
||||||
ticketID <- insertTicket now title desc source offerID acceptID
|
ticketID <- lift $ insertTicket now title desc source offerID acceptID
|
||||||
clothID <- insertMerge recipLoomID ticketID maybeTargetBranch originOrBundle'
|
clothID <- lift $ insertMerge recipLoomID ticketID maybeTargetBranch originOrBundle'
|
||||||
let maybePull =
|
let maybePull =
|
||||||
let maybeTipInfo =
|
let maybeTipInfo =
|
||||||
case tipInfo of
|
case tipInfo of
|
||||||
|
@ -720,30 +687,24 @@ loomOfferTicketF now recipLoomHash author body mfwd luOffer ticket uTarget = do
|
||||||
in (clothID, targetRepoID, hasBundle,) <$> maybeTipInfo
|
in (clothID, targetRepoID, hasBundle,) <$> maybeTipInfo
|
||||||
|
|
||||||
-- Prepare an Accept activity and insert to loom's outbox
|
-- Prepare an Accept activity and insert to loom's outbox
|
||||||
(docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
|
(actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
|
||||||
insertAcceptToOutbox clothID acceptID
|
lift $ prepareAccept clothID
|
||||||
|
_luAccept <- lift $ updateOutboxItem (LocalActorLoom recipLoomID) acceptID actionAccept
|
||||||
|
|
||||||
-- Deliver the Accept to local recipients, and schedule delivery
|
-- Deliver the Accept to local recipients, and schedule delivery
|
||||||
-- for unavailable remote recipients
|
-- for unavailable remote recipients
|
||||||
knownRemoteRecipsAccept <-
|
deliverHttpAccept <-
|
||||||
deliverLocal'
|
deliverActivityDB
|
||||||
False (LocalActorLoom recipLoomHash) recipLoomActorID
|
(LocalActorLoom recipLoomHash) recipLoomActorID
|
||||||
acceptID localRecipsAccept
|
localRecipsAccept remoteRecipsAccept
|
||||||
remoteRecipsHttpAccept <-
|
fwdHostsAccept acceptID actionAccept
|
||||||
deliverRemoteDB''
|
|
||||||
fwdHostsAccept acceptID remoteRecipsAccept
|
|
||||||
knownRemoteRecipsAccept
|
|
||||||
|
|
||||||
-- Return instructions for HTTP inbox-forwarding of the Offer
|
-- Return instructions for HTTP inbox-forwarding of the Offer
|
||||||
-- activity, and for HTTP delivery of the Accept activity to
|
-- activity, and for HTTP delivery of the Accept activity to
|
||||||
-- remote recipients, and for generating patches from
|
-- remote recipients, and for generating patches from
|
||||||
-- the origin repo
|
-- the origin repo
|
||||||
return
|
return
|
||||||
( maybeHttpFwdOffer
|
(maybeHttpFwdOffer, deliverHttpAccept, maybePull)
|
||||||
, deliverRemoteHttp'
|
|
||||||
fwdHostsAccept acceptID docAccept remoteRecipsHttpAccept
|
|
||||||
, maybePull
|
|
||||||
)
|
|
||||||
|
|
||||||
-- Launch asynchronous HTTP forwarding of the Offer activity and HTTP
|
-- Launch asynchronous HTTP forwarding of the Offer activity and HTTP
|
||||||
-- delivery of the Accept activity, and generate patches if we opened
|
-- 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
|
NE.map (Patch bundleID now typ) diffs
|
||||||
return clothID
|
return clothID
|
||||||
|
|
||||||
insertAcceptToOutbox
|
prepareAccept clothID = do
|
||||||
:: TicketLoomId
|
|
||||||
-> OutboxItemId
|
|
||||||
-> WorkerDB
|
|
||||||
( AP.Doc AP.Activity URIMode
|
|
||||||
, RecipientRoutes
|
|
||||||
, [(Host, NonEmpty LocalURI)]
|
|
||||||
, [Host]
|
|
||||||
)
|
|
||||||
insertAcceptToOutbox clothID acceptID = do
|
|
||||||
encodeRouteLocal <- getEncodeRouteLocal
|
encodeRouteLocal <- getEncodeRouteLocal
|
||||||
encodeRouteHome <- getEncodeRouteHome
|
encodeRouteHome <- getEncodeRouteHome
|
||||||
hLocal <- asksSite siteInstanceHost
|
|
||||||
|
|
||||||
clothHash <- encodeKeyHashid clothID
|
clothHash <- encodeKeyHashid clothID
|
||||||
acceptHash <- encodeKeyHashid acceptID
|
|
||||||
|
|
||||||
ra <- getJust $ remoteAuthorId author
|
ra <- getJust $ remoteAuthorId author
|
||||||
|
|
||||||
|
@ -842,26 +792,20 @@ loomOfferTicketF now recipLoomHash author body mfwd luOffer ticket uTarget = do
|
||||||
collectAudience [audSender, audTracker]
|
collectAudience [audSender, audTracker]
|
||||||
|
|
||||||
recips = map encodeRouteHome audLocal ++ audRemote
|
recips = map encodeRouteHome audLocal ++ audRemote
|
||||||
doc = AP.Doc hLocal AP.Activity
|
action = AP.Action
|
||||||
{ AP.activityId =
|
{ AP.actionCapability = Nothing
|
||||||
Just $ encodeRouteLocal $
|
, AP.actionSummary = Nothing
|
||||||
LoomOutboxItemR recipLoomHash acceptHash
|
, AP.actionAudience = AP.Audience recips [] [] [] [] []
|
||||||
, AP.activityActor =
|
, AP.actionFulfills = []
|
||||||
encodeRouteLocal $ LoomR recipLoomHash
|
, AP.actionSpecific = AP.AcceptActivity AP.Accept
|
||||||
, AP.activityCapability = Nothing
|
{ AP.acceptObject = ObjURI hAuthor luOffer
|
||||||
, AP.activitySummary = Nothing
|
, AP.acceptResult =
|
||||||
, AP.activityAudience = AP.Audience recips [] [] [] [] []
|
|
||||||
, AP.activityFulfills = []
|
|
||||||
, AP.activitySpecific = AP.AcceptActivity AP.Accept
|
|
||||||
{ acceptObject = ObjURI hAuthor luOffer
|
|
||||||
, acceptResult =
|
|
||||||
Just $ encodeRouteLocal $
|
Just $ encodeRouteLocal $
|
||||||
ClothR recipLoomHash clothHash
|
ClothR recipLoomHash clothHash
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
update acceptID [OutboxItemActivity =. persistJSONObjectFromDoc doc]
|
return (action, recipientSet, remoteActors, fwdHosts)
|
||||||
return (doc, recipientSet, remoteActors, fwdHosts)
|
|
||||||
|
|
||||||
repoOfferTicketF
|
repoOfferTicketF
|
||||||
:: UTCTime
|
:: UTCTime
|
||||||
|
@ -918,7 +862,7 @@ repoOfferTicketF now recipHash author body mfwd luOffer ticket uTarget = do
|
||||||
obiidAccept
|
obiidAccept
|
||||||
localRecipsAccept
|
localRecipsAccept
|
||||||
(obiidAccept,docAccept,fwdHostsAccept,) <$>
|
(obiidAccept,docAccept,fwdHostsAccept,) <$>
|
||||||
deliverRemoteDB'' fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept
|
deliverRemoteDB fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept
|
||||||
return (mremotesHttpFwd, obiidAccept, docAccept, fwdHostsAccept, recipsAccept)
|
return (mremotesHttpFwd, obiidAccept, docAccept, fwdHostsAccept, recipsAccept)
|
||||||
case mmhttp of
|
case mmhttp of
|
||||||
Nothing -> return "Offer target isn't me, not using"
|
Nothing -> return "Offer target isn't me, not using"
|
||||||
|
@ -1085,7 +1029,7 @@ repoAddBundleF now recipHash author body mfwd luAdd patches uTarget = do
|
||||||
obiidAccept
|
obiidAccept
|
||||||
localRecipsAccept
|
localRecipsAccept
|
||||||
(obiidAccept,docAccept,fwdHostsAccept,) <$>
|
(obiidAccept,docAccept,fwdHostsAccept,) <$>
|
||||||
deliverRemoteDB'' fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept
|
deliverRemoteDB fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept
|
||||||
return (mremotesHttpFwd, mremotesHttpAccept)
|
return (mremotesHttpFwd, mremotesHttpAccept)
|
||||||
case mhttp of
|
case mhttp of
|
||||||
Nothing -> return "I already have this activity in my inbox, doing nothing"
|
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
|
-- Apply patches
|
||||||
applyPatches repoID maybeBranch diffs
|
applyPatches repoID maybeBranch diffs
|
||||||
|
|
||||||
maybeHttp <- lift $ runDB $ do
|
maybeHttp <- runDBExcept $ do
|
||||||
|
|
||||||
-- Insert the Apply to loom's inbox
|
-- 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
|
for mractid $ \ applyID -> do
|
||||||
|
|
||||||
-- Forward the Apply activity to relevant local stages, and
|
-- Forward the Apply activity to relevant local stages, and
|
||||||
-- schedule delivery for unavailable remote members of them
|
-- schedule delivery for unavailable remote members of them
|
||||||
maybeHttpFwdApply <- for mfwd $ \ (localRecips, sig) -> do
|
maybeHttpFwdApply <- lift $ for mfwd $ \ (localRecips, sig) -> do
|
||||||
clothHash <- encodeKeyHashid clothID
|
clothHash <- encodeKeyHashid clothID
|
||||||
let sieve =
|
let sieve =
|
||||||
makeRecipientSet
|
makeRecipientSet
|
||||||
|
@ -1258,44 +1202,32 @@ loomApplyF now recipLoomHash author body mfwd luApply apply = (,Nothing) <$> do
|
||||||
[ LocalStageLoomFollowers recipLoomHash
|
[ LocalStageLoomFollowers recipLoomHash
|
||||||
, LocalStageClothFollowers recipLoomHash clothHash
|
, LocalStageClothFollowers recipLoomHash clothHash
|
||||||
]
|
]
|
||||||
remoteRecips <-
|
forwardActivityDB
|
||||||
insertRemoteActivityToLocalInboxes False applyID $
|
(actbBL body) localRecips sig recipLoomActorID
|
||||||
localRecipSieve' sieve False False localRecips
|
(LocalActorLoom recipLoomHash) sieve applyID
|
||||||
remoteRecipsHttp <-
|
|
||||||
deliverRemoteDB_L
|
|
||||||
(actbBL body) applyID recipLoomID sig remoteRecips
|
|
||||||
return $
|
|
||||||
deliverRemoteHTTP_L
|
|
||||||
now recipLoomHash (actbBL body) sig remoteRecipsHttp
|
|
||||||
|
|
||||||
-- Mark ticket in DB as resolved by the Apply
|
-- Mark ticket in DB as resolved by the Apply
|
||||||
acceptID <-
|
acceptID <-
|
||||||
insertEmptyOutboxItem (actorOutbox recipLoomActor) now
|
lift $ insertEmptyOutboxItem (actorOutbox recipLoomActor) now
|
||||||
insertResolve ticketID applyID acceptID
|
lift $ insertResolve ticketID applyID acceptID
|
||||||
|
|
||||||
-- Prepare an Accept activity and insert to loom's outbox
|
-- Prepare an Accept activity and insert to loom's outbox
|
||||||
(docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
|
(actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
|
||||||
insertAcceptToOutbox uCap clothID acceptID
|
lift $ prepareAccept clothID
|
||||||
|
_luAccept <- lift $ updateOutboxItem (LocalActorLoom recipLoomID) acceptID actionAccept
|
||||||
|
|
||||||
-- Deliver the Accept to local recipients, and schedule delivery
|
-- Deliver the Accept to local recipients, and schedule delivery
|
||||||
-- for unavailable remote recipients
|
-- for unavailable remote recipients
|
||||||
knownRemoteRecipsAccept <-
|
deliverHttpAccept <-
|
||||||
deliverLocal'
|
deliverActivityDB
|
||||||
False (LocalActorLoom recipLoomHash) recipLoomActorID
|
(LocalActorLoom recipLoomHash) recipLoomActorID
|
||||||
acceptID localRecipsAccept
|
localRecipsAccept remoteRecipsAccept fwdHostsAccept
|
||||||
remoteRecipsHttpAccept <-
|
acceptID actionAccept
|
||||||
deliverRemoteDB''
|
|
||||||
fwdHostsAccept acceptID remoteRecipsAccept
|
|
||||||
knownRemoteRecipsAccept
|
|
||||||
|
|
||||||
-- Return instructions for HTTP inbox-forwarding of the Apply
|
-- Return instructions for HTTP inbox-forwarding of the Apply
|
||||||
-- activity, and for HTTP delivery of the Accept activity to
|
-- activity, and for HTTP delivery of the Accept activity to
|
||||||
-- remote recipients
|
-- remote recipients
|
||||||
return
|
return (maybeHttpFwdApply, deliverHttpAccept)
|
||||||
( maybeHttpFwdApply
|
|
||||||
, deliverRemoteHttp'
|
|
||||||
fwdHostsAccept acceptID docAccept remoteRecipsHttpAccept
|
|
||||||
)
|
|
||||||
|
|
||||||
-- Launch asynchronous HTTP forwarding of the Apply activity and HTTP
|
-- Launch asynchronous HTTP forwarding of the Apply activity and HTTP
|
||||||
-- delivery of the Accept activity
|
-- delivery of the Accept activity
|
||||||
|
@ -1326,13 +1258,10 @@ loomApplyF now recipLoomHash author body mfwd luApply apply = (,Nothing) <$> do
|
||||||
}
|
}
|
||||||
update ticketID [TicketStatus =. TSClosed]
|
update ticketID [TicketStatus =. TSClosed]
|
||||||
|
|
||||||
insertAcceptToOutbox uCap clothID acceptID = do
|
prepareAccept clothID = do
|
||||||
encodeRouteLocal <- getEncodeRouteLocal
|
|
||||||
encodeRouteHome <- getEncodeRouteHome
|
encodeRouteHome <- getEncodeRouteHome
|
||||||
hLocal <- asksSite siteInstanceHost
|
|
||||||
|
|
||||||
clothHash <- encodeKeyHashid clothID
|
clothHash <- encodeKeyHashid clothID
|
||||||
acceptHash <- encodeKeyHashid acceptID
|
|
||||||
|
|
||||||
ra <- getJust $ remoteAuthorId author
|
ra <- getJust $ remoteAuthorId author
|
||||||
|
|
||||||
|
@ -1353,24 +1282,18 @@ loomApplyF now recipLoomHash author body mfwd luApply apply = (,Nothing) <$> do
|
||||||
collectAudience [audSender, audTracker]
|
collectAudience [audSender, audTracker]
|
||||||
|
|
||||||
recips = map encodeRouteHome audLocal ++ audRemote
|
recips = map encodeRouteHome audLocal ++ audRemote
|
||||||
doc = AP.Doc hLocal AP.Activity
|
action = AP.Action
|
||||||
{ AP.activityId =
|
{ AP.actionCapability = Nothing
|
||||||
Just $ encodeRouteLocal $
|
, AP.actionSummary = Nothing
|
||||||
LoomOutboxItemR recipLoomHash acceptHash
|
, AP.actionAudience = AP.Audience recips [] [] [] [] []
|
||||||
, AP.activityActor =
|
, AP.actionFulfills = []
|
||||||
encodeRouteLocal $ LoomR recipLoomHash
|
, AP.actionSpecific = AP.AcceptActivity AP.Accept
|
||||||
, AP.activityCapability = Just uCap
|
{ AP.acceptObject = ObjURI hAuthor luApply
|
||||||
, AP.activitySummary = Nothing
|
, AP.acceptResult = Nothing
|
||||||
, AP.activityAudience = AP.Audience recips [] [] [] [] []
|
|
||||||
, AP.activityFulfills = []
|
|
||||||
, AP.activitySpecific = AP.AcceptActivity AP.Accept
|
|
||||||
{ acceptObject = ObjURI hAuthor luApply
|
|
||||||
, acceptResult = Nothing
|
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
update acceptID [OutboxItemActivity =. persistJSONObjectFromDoc doc]
|
return (action, recipientSet, remoteActors, fwdHosts)
|
||||||
return (doc, recipientSet, remoteActors, fwdHosts)
|
|
||||||
|
|
||||||
personOfferDepF
|
personOfferDepF
|
||||||
:: UTCTime
|
:: UTCTime
|
||||||
|
@ -1430,7 +1353,7 @@ personOfferDepF now recipHash author body mfwd luOffer dep uTarget = do
|
||||||
(personInbox personRecip)
|
(personInbox personRecip)
|
||||||
obiidAccept
|
obiidAccept
|
||||||
localRecipsAccept
|
localRecipsAccept
|
||||||
(obiidAccept,docAccept,fwdHostsAccept,) <$> deliverRemoteDB'' fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept
|
(obiidAccept,docAccept,fwdHostsAccept,) <$> deliverRemoteDB fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept
|
||||||
return (mremotesHttpFwd, mremotesHttpAccept)
|
return (mremotesHttpFwd, mremotesHttpAccept)
|
||||||
case mhttp of
|
case mhttp of
|
||||||
Nothing -> return "I already have this activity in my inbox, doing nothing"
|
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)
|
(actorInbox actorRecip)
|
||||||
obiidAccept
|
obiidAccept
|
||||||
localRecipsAccept
|
localRecipsAccept
|
||||||
(obiidAccept,docAccept,fwdHostsAccept,) <$> deliverRemoteDB'' fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept
|
(obiidAccept,docAccept,fwdHostsAccept,) <$> deliverRemoteDB fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept
|
||||||
return (mremotesHttpFwd, mremotesHttpAccept)
|
return (mremotesHttpFwd, mremotesHttpAccept)
|
||||||
case mhttp of
|
case mhttp of
|
||||||
Nothing -> return "I already have this activity in my inbox, doing nothing"
|
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)
|
(repoInbox repoRecip)
|
||||||
obiidAccept
|
obiidAccept
|
||||||
localRecipsAccept
|
localRecipsAccept
|
||||||
(obiidAccept,docAccept,fwdHostsAccept,) <$> deliverRemoteDB'' fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept
|
(obiidAccept,docAccept,fwdHostsAccept,) <$> deliverRemoteDB fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept
|
||||||
return (mremotesHttpFwd, mremotesHttpAccept)
|
return (mremotesHttpFwd, mremotesHttpAccept)
|
||||||
case mhttp of
|
case mhttp of
|
||||||
Nothing -> return "I already have this activity in my inbox, doing nothing"
|
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
|
obiidAccept
|
||||||
localRecipsAccept
|
localRecipsAccept
|
||||||
(mremotesHttpFwd,obiidAccept,docAccept,fwdHostsAccept,) <$>
|
(mremotesHttpFwd,obiidAccept,docAccept,fwdHostsAccept,) <$>
|
||||||
deliverRemoteDB'' fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept
|
deliverRemoteDB fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept
|
||||||
case mmmmhttp of
|
case mmmmhttp of
|
||||||
Nothing -> return "I already have this activity in my inbox, doing nothing"
|
Nothing -> return "I already have this activity in my inbox, doing nothing"
|
||||||
Just mmmhttp ->
|
Just mmmhttp ->
|
||||||
|
@ -2144,7 +2067,7 @@ repoResolveF now recipHash author body mfwd luResolve (Resolve uObject) = do
|
||||||
obiidAccept
|
obiidAccept
|
||||||
localRecipsAccept
|
localRecipsAccept
|
||||||
(mremotesHttpFwd,obiidAccept,docAccept,fwdHostsAccept,) <$>
|
(mremotesHttpFwd,obiidAccept,docAccept,fwdHostsAccept,) <$>
|
||||||
deliverRemoteDB'' fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept
|
deliverRemoteDB fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept
|
||||||
case mmmmhttp of
|
case mmmmhttp of
|
||||||
Nothing -> return "I already have this activity in my inbox, doing nothing"
|
Nothing -> return "I already have this activity in my inbox, doing nothing"
|
||||||
Just mmmhttp ->
|
Just mmmhttp ->
|
||||||
|
|
|
@ -86,7 +86,7 @@ import Vervis.Cloth
|
||||||
import Vervis.Data.Actor
|
import Vervis.Data.Actor
|
||||||
import Vervis.Data.Collab
|
import Vervis.Data.Collab
|
||||||
import Vervis.Data.Ticket
|
import Vervis.Data.Ticket
|
||||||
import Vervis.Delivery
|
import Vervis.Web.Delivery
|
||||||
import Vervis.FedURI
|
import Vervis.FedURI
|
||||||
import Vervis.Foundation
|
import Vervis.Foundation
|
||||||
import Vervis.Model
|
import Vervis.Model
|
||||||
|
|
|
@ -69,6 +69,7 @@ import Yesod.Mail.Send
|
||||||
|
|
||||||
import qualified Network.HTTP.Signature as S (Algorithm (..))
|
import qualified Network.HTTP.Signature as S (Algorithm (..))
|
||||||
|
|
||||||
|
import Crypto.ActorKey
|
||||||
import Crypto.PublicVerifKey
|
import Crypto.PublicVerifKey
|
||||||
import Network.FedURI
|
import Network.FedURI
|
||||||
import Web.ActivityAccess
|
import Web.ActivityAccess
|
||||||
|
@ -83,7 +84,6 @@ import Text.Email.Local
|
||||||
import Text.Jasmine.Local (discardm)
|
import Text.Jasmine.Local (discardm)
|
||||||
import Yesod.Paginate.Local
|
import Yesod.Paginate.Local
|
||||||
|
|
||||||
import Vervis.ActorKey
|
|
||||||
import Vervis.FedURI
|
import Vervis.FedURI
|
||||||
import Vervis.Hook
|
import Vervis.Hook
|
||||||
import Vervis.Model
|
import Vervis.Model
|
||||||
|
@ -114,7 +114,7 @@ data App = App
|
||||||
, appLogger :: Logger
|
, appLogger :: Logger
|
||||||
, appMailQueue :: Maybe (Chan (MailRecipe App))
|
, appMailQueue :: Maybe (Chan (MailRecipe App))
|
||||||
, appSvgFont :: PreparedFont Double
|
, appSvgFont :: PreparedFont Double
|
||||||
, appActorKeys :: TVar (ActorKey, ActorKey, Bool)
|
, appActorKeys :: Maybe (TVar (ActorKey, ActorKey, Bool))
|
||||||
, appInstanceMutex :: InstanceMutex
|
, appInstanceMutex :: InstanceMutex
|
||||||
, appCapSignKey :: AccessTokenSecretKey
|
, appCapSignKey :: AccessTokenSecretKey
|
||||||
, appHashidsContext :: HashidsContext
|
, appHashidsContext :: HashidsContext
|
||||||
|
@ -140,6 +140,7 @@ type DeckKeyHashid = KeyHashid Deck
|
||||||
type LoomKeyHashid = KeyHashid Loom
|
type LoomKeyHashid = KeyHashid Loom
|
||||||
type TicketDeckKeyHashid = KeyHashid TicketDeck
|
type TicketDeckKeyHashid = KeyHashid TicketDeck
|
||||||
type TicketLoomKeyHashid = KeyHashid TicketLoom
|
type TicketLoomKeyHashid = KeyHashid TicketLoom
|
||||||
|
type SigKeyKeyHashid = KeyHashid SigKey
|
||||||
|
|
||||||
-- This is where we define all of the routes in our application. For a full
|
-- This is where we define all of the routes in our application. For a full
|
||||||
-- explanation of the syntax, please see:
|
-- explanation of the syntax, please see:
|
||||||
|
@ -783,6 +784,7 @@ instance YesodActivityPub App where
|
||||||
siteInstanceHost = appInstanceHost . appSettings
|
siteInstanceHost = appInstanceHost . appSettings
|
||||||
sitePostSignedHeaders _ =
|
sitePostSignedHeaders _ =
|
||||||
hRequestTarget :| [hHost, hDate, hDigest, AP.hActivityPubActor]
|
hRequestTarget :| [hHost, hDate, hDigest, AP.hActivityPubActor]
|
||||||
|
{-
|
||||||
siteGetHttpSign = do
|
siteGetHttpSign = do
|
||||||
(akey1, akey2, new1) <- liftIO . readTVarIO =<< asksSite appActorKeys
|
(akey1, akey2, new1) <- liftIO . readTVarIO =<< asksSite appActorKeys
|
||||||
renderUrl <- askUrlRender
|
renderUrl <- askUrlRender
|
||||||
|
@ -791,6 +793,7 @@ instance YesodActivityPub App where
|
||||||
then (renderUrl ActorKey1R, akey1)
|
then (renderUrl ActorKey1R, akey1)
|
||||||
else (renderUrl ActorKey2R, akey2)
|
else (renderUrl ActorKey2R, akey2)
|
||||||
return (KeyId $ encodeUtf8 keyID, actorKeySign akey)
|
return (KeyId $ encodeUtf8 keyID, actorKeySign akey)
|
||||||
|
-}
|
||||||
|
|
||||||
instance YesodPaginate App where
|
instance YesodPaginate App where
|
||||||
sitePageParamName _ = "page"
|
sitePageParamName _ = "page"
|
||||||
|
@ -837,12 +840,16 @@ instance YesodBreadcrumbs App where
|
||||||
|
|
||||||
ReplyR _ -> ("", Nothing)
|
ReplyR _ -> ("", Nothing)
|
||||||
|
|
||||||
|
PersonStampR p k -> ("Stamp #" <> keyHashidText k, Just $ PersonR p)
|
||||||
|
|
||||||
GroupR g -> ("Team &" <> keyHashidText g, Just HomeR)
|
GroupR g -> ("Team &" <> keyHashidText g, Just HomeR)
|
||||||
GroupInboxR g -> ("Inbox", Just $ GroupR g)
|
GroupInboxR g -> ("Inbox", Just $ GroupR g)
|
||||||
GroupOutboxR g -> ("Outbox", Just $ GroupR g)
|
GroupOutboxR g -> ("Outbox", Just $ GroupR g)
|
||||||
GroupOutboxItemR g i -> (keyHashidText i, Just $ GroupOutboxR g)
|
GroupOutboxItemR g i -> (keyHashidText i, Just $ GroupOutboxR g)
|
||||||
GroupFollowersR g -> ("Followers", Just $ GroupR g)
|
GroupFollowersR g -> ("Followers", Just $ GroupR g)
|
||||||
|
|
||||||
|
GroupStampR g k -> ("Stamp #" <> keyHashidText k, Just $ GroupR g)
|
||||||
|
|
||||||
RepoR r -> ("Repo ^" <> keyHashidText r, Just HomeR)
|
RepoR r -> ("Repo ^" <> keyHashidText r, Just HomeR)
|
||||||
RepoInboxR r -> ("Inbox", Just $ RepoR r)
|
RepoInboxR r -> ("Inbox", Just $ RepoR r)
|
||||||
RepoOutboxR r -> ("Outbox", Just $ RepoR r)
|
RepoOutboxR r -> ("Outbox", Just $ RepoR r)
|
||||||
|
@ -871,6 +878,8 @@ instance YesodBreadcrumbs App where
|
||||||
|
|
||||||
RepoLinkR _ _ -> ("", Nothing)
|
RepoLinkR _ _ -> ("", Nothing)
|
||||||
|
|
||||||
|
RepoStampR r k -> ("Stamp #" <> keyHashidText k, Just $ RepoR r)
|
||||||
|
|
||||||
DeckR d -> ("Ticket Tracker =" <> keyHashidText d, Just HomeR)
|
DeckR d -> ("Ticket Tracker =" <> keyHashidText d, Just HomeR)
|
||||||
DeckInboxR d -> ("Inbox", Just $ DeckR d)
|
DeckInboxR d -> ("Inbox", Just $ DeckR d)
|
||||||
DeckOutboxR d -> ("Outbox", Just $ DeckR d)
|
DeckOutboxR d -> ("Outbox", Just $ DeckR d)
|
||||||
|
@ -886,6 +895,8 @@ instance YesodBreadcrumbs App where
|
||||||
DeckFollowR _ -> ("", Nothing)
|
DeckFollowR _ -> ("", Nothing)
|
||||||
DeckUnfollowR _ -> ("", Nothing)
|
DeckUnfollowR _ -> ("", Nothing)
|
||||||
|
|
||||||
|
DeckStampR d k -> ("Stamp #" <> keyHashidText k, Just $ DeckR d)
|
||||||
|
|
||||||
TicketR d t -> ("#" <> keyHashidText t, Just $ DeckTicketsR d)
|
TicketR d t -> ("#" <> keyHashidText t, Just $ DeckTicketsR d)
|
||||||
TicketDiscussionR d t -> ("Discussion", Just $ TicketR d t)
|
TicketDiscussionR d t -> ("Discussion", Just $ TicketR d t)
|
||||||
TicketEventsR d t -> ("Events", Just $ TicketR d t)
|
TicketEventsR d t -> ("Events", Just $ TicketR d t)
|
||||||
|
@ -910,6 +921,8 @@ instance YesodBreadcrumbs App where
|
||||||
LoomFollowR _ -> ("", Nothing)
|
LoomFollowR _ -> ("", Nothing)
|
||||||
LoomUnfollowR _ -> ("", Nothing)
|
LoomUnfollowR _ -> ("", Nothing)
|
||||||
|
|
||||||
|
LoomStampR l k -> ("Stamp #" <> keyHashidText k, Just $ LoomR l)
|
||||||
|
|
||||||
ClothR l c -> ("#" <> keyHashidText c, Just $ LoomClothsR l)
|
ClothR l c -> ("#" <> keyHashidText c, Just $ LoomClothsR l)
|
||||||
ClothDiscussionR l c -> ("Discussion", Just $ ClothR l c)
|
ClothDiscussionR l c -> ("Discussion", Just $ ClothR l c)
|
||||||
ClothEventsR l c -> ("Events", Just $ ClothR l c)
|
ClothEventsR l c -> ("Events", Just $ ClothR l c)
|
||||||
|
|
|
@ -37,43 +37,32 @@ where
|
||||||
|
|
||||||
import Control.Applicative
|
import Control.Applicative
|
||||||
import Control.Concurrent.STM.TVar
|
import Control.Concurrent.STM.TVar
|
||||||
import Control.Exception hiding (Handler)
|
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
import Control.Monad.Trans.Except
|
import Control.Monad.Trans.Except
|
||||||
import Data.Bitraversable
|
|
||||||
import Data.List
|
import Data.List
|
||||||
import Data.Maybe
|
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
import Data.Time.Clock
|
import Data.Time.Clock
|
||||||
import Data.Traversable
|
import Data.Traversable
|
||||||
import Database.Persist
|
import Database.Persist
|
||||||
import Text.Blaze.Html (preEscapedToHtml)
|
import Text.Blaze.Html (preEscapedToHtml)
|
||||||
import Text.Blaze.Html.Renderer.Text
|
|
||||||
import Text.HTML.SanitizeXSS
|
|
||||||
import Yesod.Auth
|
import Yesod.Auth
|
||||||
import Yesod.Auth.Account
|
import Yesod.Auth.Account
|
||||||
import Yesod.Auth.Account.Message
|
import Yesod.Auth.Account.Message
|
||||||
import Yesod.Core
|
import Yesod.Core
|
||||||
import Yesod.Core.Widget
|
|
||||||
import Yesod.Form
|
import Yesod.Form
|
||||||
import Yesod.Persist.Core
|
import Yesod.Persist.Core
|
||||||
|
|
||||||
import qualified Data.ByteString.Char8 as BC
|
import qualified Data.ByteString.Char8 as BC
|
||||||
import qualified Data.HashMap.Strict as M
|
import qualified Data.HashMap.Strict as M
|
||||||
import qualified Data.Text as T
|
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 Data.Text.Lazy.Encoding as TLE
|
||||||
import qualified Database.Esqueleto as E
|
import qualified Database.Esqueleto as E
|
||||||
|
|
||||||
import Dvara
|
|
||||||
|
|
||||||
import Database.Persist.JSON
|
import Database.Persist.JSON
|
||||||
import Network.FedURI
|
import Network.FedURI
|
||||||
import Web.Text
|
import Web.Text
|
||||||
import Yesod.ActivityPub
|
import Yesod.ActivityPub
|
||||||
import Yesod.Auth.Unverified
|
import Yesod.Auth.Unverified
|
||||||
import Yesod.FedURI
|
|
||||||
import Yesod.Hashids
|
import Yesod.Hashids
|
||||||
import Yesod.MonadSite
|
import Yesod.MonadSite
|
||||||
import Yesod.RenderSource
|
import Yesod.RenderSource
|
||||||
|
@ -83,26 +72,19 @@ import qualified Web.ActivityPub as AP
|
||||||
import Control.Monad.Trans.Except.Local
|
import Control.Monad.Trans.Except.Local
|
||||||
import Data.Either.Local
|
import Data.Either.Local
|
||||||
import Data.EventTime.Local
|
import Data.EventTime.Local
|
||||||
import Data.Time.Clock.Local
|
|
||||||
import Database.Persist.Local
|
import Database.Persist.Local
|
||||||
import Yesod.Form.Local
|
import Yesod.Form.Local
|
||||||
import Yesod.Persist.Local
|
|
||||||
|
|
||||||
import Vervis.ActivityPub
|
|
||||||
import Vervis.ActorKey
|
|
||||||
import Vervis.API
|
import Vervis.API
|
||||||
import Vervis.Client
|
import Vervis.Client
|
||||||
|
import Vervis.Data.Actor
|
||||||
import Vervis.FedURI
|
import Vervis.FedURI
|
||||||
import Vervis.Foundation
|
import Vervis.Foundation
|
||||||
import Vervis.Model
|
import Vervis.Model
|
||||||
import Vervis.Model.Ident
|
import Vervis.Model.Ident
|
||||||
import Development.PatchMediaType
|
import Vervis.Recipient
|
||||||
import Vervis.Path
|
|
||||||
import Vervis.Settings
|
import Vervis.Settings
|
||||||
import Vervis.Ticket
|
import Vervis.Web.Actor
|
||||||
|
|
||||||
import qualified Vervis.Darcs as D
|
|
||||||
import qualified Vervis.Git as G
|
|
||||||
|
|
||||||
-- | Account verification email resend form
|
-- | Account verification email resend form
|
||||||
getResendVerifyEmailR :: Handler Html
|
getResendVerifyEmailR :: Handler Html
|
||||||
|
@ -115,28 +97,11 @@ getResendVerifyEmailR = do
|
||||||
^{resendVerifyEmailWidget (username person) AuthR}
|
^{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 :: Handler TypedContent
|
||||||
getActorKey1R = getActorKey (\ (k1, _, _) -> k1) ActorKey1R
|
getActorKey1R = serveInstanceKey fst ActorKey1R
|
||||||
|
|
||||||
getActorKey2R :: Handler TypedContent
|
getActorKey2R :: Handler TypedContent
|
||||||
getActorKey2R = getActorKey (\ (_, k2, _) -> k2) ActorKey2R
|
getActorKey2R = serveInstanceKey snd ActorKey2R
|
||||||
|
|
||||||
getHomeR :: Handler Html
|
getHomeR :: Handler Html
|
||||||
getHomeR = do
|
getHomeR = do
|
||||||
|
@ -1063,6 +1028,18 @@ fedUriField = Field
|
||||||
, fieldEnctype = UrlEncoded
|
, 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 :: Handler (Entity Person, Actor)
|
||||||
getSender = do
|
getSender = do
|
||||||
ep@(Entity _ p) <- requireAuth
|
ep@(Entity _ p) <- requireAuth
|
||||||
|
@ -1153,7 +1130,9 @@ postPublishOfferMergeR = do
|
||||||
senderHash omgTitle omgDesc omgTracker
|
senderHash omgTitle omgDesc omgTracker
|
||||||
omgTargetRepo (Just omgTargetBranch)
|
omgTargetRepo (Just omgTargetBranch)
|
||||||
omgOriginRepo (Just omgOriginBranch)
|
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
|
if trackerLocal
|
||||||
then nameExceptT "Offer published but" $ runDBExcept $ do
|
then nameExceptT "Offer published but" $ runDBExcept $ do
|
||||||
ticketID <- do
|
ticketID <- do
|
||||||
|
@ -1175,10 +1154,9 @@ postPublishOfferMergeR = do
|
||||||
else setMessage "Offer published"
|
else setMessage "Offer published"
|
||||||
redirect dest
|
redirect dest
|
||||||
|
|
||||||
mergeForm :: Form (FedURI, FedURI)
|
|
||||||
mergeForm = renderDivs $ (,)
|
mergeForm = renderDivs $ (,)
|
||||||
<$> areq fedUriField "Patch bundle to apply" Nothing
|
<$> 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 :: Handler Html
|
||||||
getPublishMergeR = do
|
getPublishMergeR = do
|
||||||
|
@ -1196,14 +1174,16 @@ postPublishMergeR = do
|
||||||
federation <- getsYesod $ appFederation . appSettings
|
federation <- getsYesod $ appFederation . appSettings
|
||||||
unless federation badMethod
|
unless federation badMethod
|
||||||
|
|
||||||
(uBundle, uCap) <- runFormPostRedirect PublishMergeR mergeForm
|
(uBundle, (uCap, cap)) <- runFormPostRedirect PublishMergeR mergeForm
|
||||||
|
|
||||||
(ep@(Entity pid _), a) <- getSender
|
(ep@(Entity pid _), a) <- getSender
|
||||||
senderHash <- encodeKeyHashid pid
|
senderHash <- encodeKeyHashid pid
|
||||||
|
|
||||||
result <- runExceptT $ do
|
result <- runExceptT $ do
|
||||||
(maybeSummary, audience, apply) <- applyPatches senderHash uBundle
|
(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
|
case result of
|
||||||
Left err -> do
|
Left err -> do
|
||||||
|
|
|
@ -622,7 +622,7 @@ postClothApplyR :: KeyHashid Loom -> KeyHashid TicketLoom -> Handler ()
|
||||||
postClothApplyR loomHash clothHash = do
|
postClothApplyR loomHash clothHash = do
|
||||||
ep@(Entity personID person) <- requireAuth
|
ep@(Entity personID person) <- requireAuth
|
||||||
|
|
||||||
(grantIDs, proposal, actor) <- runDB $ do
|
(grantIDs, proposal, actor, loomID) <- runDB $ do
|
||||||
(Entity loomID _, _, _, _, _, proposal) <- getCloth404 loomHash clothHash
|
(Entity loomID _, _, _, _, _, proposal) <- getCloth404 loomHash clothHash
|
||||||
|
|
||||||
grantIDs <-
|
grantIDs <-
|
||||||
|
@ -636,7 +636,7 @@ postClothApplyR loomHash clothHash = do
|
||||||
|
|
||||||
actor <- getJust $ personActor person
|
actor <- getJust $ personActor person
|
||||||
|
|
||||||
return (map E.unValue grantIDs, proposal, actor)
|
return (map E.unValue grantIDs, proposal, actor, loomID)
|
||||||
|
|
||||||
result <- runExceptT $ do
|
result <- runExceptT $ do
|
||||||
|
|
||||||
|
@ -652,10 +652,13 @@ postClothApplyR loomHash clothHash = do
|
||||||
personHash <- encodeKeyHashid personID
|
personHash <- encodeKeyHashid personID
|
||||||
(maybeSummary, audience, apply) <-
|
(maybeSummary, audience, apply) <-
|
||||||
C.applyPatches personHash $ encodeRouteHome bundleRoute
|
C.applyPatches personHash $ encodeRouteHome bundleRoute
|
||||||
|
let cap = (LocalActorLoom loomID, LocalActorLoom loomHash, grantID)
|
||||||
uCap <-
|
uCap <-
|
||||||
encodeRouteHome . LoomOutboxItemR loomHash <$>
|
encodeRouteHome . LoomOutboxItemR loomHash <$>
|
||||||
encodeKeyHashid grantID
|
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
|
case result of
|
||||||
Left e -> setMessage $ toHtml e
|
Left e -> setMessage $ toHtml e
|
||||||
|
|
|
@ -32,6 +32,7 @@ module Vervis.Handler.Deck
|
||||||
, postDeckFollowR
|
, postDeckFollowR
|
||||||
, postDeckUnfollowR
|
, postDeckUnfollowR
|
||||||
|
|
||||||
|
, getDeckStampR
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
@ -318,9 +319,11 @@ postDeckNewR = do
|
||||||
personEntity@(Entity personID person) <- requireAuth
|
personEntity@(Entity personID person) <- requireAuth
|
||||||
personHash <- encodeKeyHashid personID
|
personHash <- encodeKeyHashid personID
|
||||||
(maybeSummary, audience, detail) <- C.createDeck personHash name desc
|
(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
|
actor <- runDB $ getJust $ personActor person
|
||||||
result <-
|
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
|
case result of
|
||||||
Left e -> do
|
Left e -> do
|
||||||
|
@ -378,6 +381,8 @@ postDeckFollowR _ = error "Temporarily disabled"
|
||||||
postDeckUnfollowR :: KeyHashid Deck -> Handler ()
|
postDeckUnfollowR :: KeyHashid Deck -> Handler ()
|
||||||
postDeckUnfollowR _ = error "Temporarily disabled"
|
postDeckUnfollowR _ = error "Temporarily disabled"
|
||||||
|
|
||||||
|
getDeckStampR :: KeyHashid Deck -> KeyHashid SigKey -> Handler TypedContent
|
||||||
|
getDeckStampR = servePerActorKey deckActor LocalActorDeck
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
|
@ -21,6 +21,7 @@ module Vervis.Handler.Group
|
||||||
, getGroupOutboxItemR
|
, getGroupOutboxItemR
|
||||||
, getGroupFollowersR
|
, getGroupFollowersR
|
||||||
|
|
||||||
|
, getGroupStampR
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
@ -129,6 +130,9 @@ getGroupOutboxItemR = getOutboxItem GroupOutboxItemR groupActor
|
||||||
getGroupFollowersR :: KeyHashid Group -> Handler TypedContent
|
getGroupFollowersR :: KeyHashid Group -> Handler TypedContent
|
||||||
getGroupFollowersR = getActorFollowersCollection GroupFollowersR groupActor
|
getGroupFollowersR = getActorFollowersCollection GroupFollowersR groupActor
|
||||||
|
|
||||||
|
getGroupStampR :: KeyHashid Group -> KeyHashid SigKey -> Handler TypedContent
|
||||||
|
getGroupStampR = servePerActorKey groupActor LocalActorGroup
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
|
@ -26,6 +26,8 @@ module Vervis.Handler.Loom
|
||||||
, postLoomNewR
|
, postLoomNewR
|
||||||
, postLoomFollowR
|
, postLoomFollowR
|
||||||
, postLoomUnfollowR
|
, postLoomUnfollowR
|
||||||
|
|
||||||
|
, getLoomStampR
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
|
@ -285,8 +287,10 @@ postLoomNewR = do
|
||||||
|
|
||||||
getJust $ personActor person
|
getJust $ personActor person
|
||||||
|
|
||||||
result <-
|
result <- do
|
||||||
runExceptT $ createPatchTrackerC personEntity actor maybeSummary audience detail repos Nothing Nothing
|
(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
|
case result of
|
||||||
Left e -> do
|
Left e -> do
|
||||||
|
@ -306,3 +310,6 @@ postLoomFollowR _ = error "Temporarily disabled"
|
||||||
|
|
||||||
postLoomUnfollowR :: KeyHashid Loom -> Handler ()
|
postLoomUnfollowR :: KeyHashid Loom -> Handler ()
|
||||||
postLoomUnfollowR _ = error "Temporarily disabled"
|
postLoomUnfollowR _ = error "Temporarily disabled"
|
||||||
|
|
||||||
|
getLoomStampR :: KeyHashid Loom -> KeyHashid SigKey -> Handler TypedContent
|
||||||
|
getLoomStampR = servePerActorKey loomActor LocalActorLoom
|
||||||
|
|
|
@ -29,12 +29,15 @@ module Vervis.Handler.Person
|
||||||
, postPersonUnfollowR
|
, postPersonUnfollowR
|
||||||
|
|
||||||
, postReplyR
|
, postReplyR
|
||||||
|
|
||||||
|
, getPersonStampR
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
import Control.Monad.Trans.Except
|
import Control.Monad.Trans.Except
|
||||||
import Control.Monad.Trans.Reader
|
import Control.Monad.Trans.Reader
|
||||||
|
import Data.List.NonEmpty (NonEmpty)
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
import Data.Time.Clock
|
import Data.Time.Clock
|
||||||
|
@ -67,11 +70,11 @@ import Data.Either.Local
|
||||||
import Database.Persist.Local
|
import Database.Persist.Local
|
||||||
|
|
||||||
import Vervis.ActivityPub
|
import Vervis.ActivityPub
|
||||||
import Vervis.ActorKey
|
|
||||||
import Vervis.API
|
import Vervis.API
|
||||||
import Vervis.Data.Actor
|
import Vervis.Data.Actor
|
||||||
import Vervis.Federation.Auth
|
import Vervis.Federation.Auth
|
||||||
import Vervis.Federation.Collab
|
import Vervis.Federation.Collab
|
||||||
|
import Vervis.FedURI
|
||||||
import Vervis.Foundation
|
import Vervis.Foundation
|
||||||
import Vervis.Model
|
import Vervis.Model
|
||||||
import Vervis.Model.Ident
|
import Vervis.Model.Ident
|
||||||
|
@ -272,12 +275,42 @@ postPersonOutboxR personHash = do
|
||||||
Just (PersonR actorHash) | actorHash == personHash -> return ()
|
Just (PersonR actorHash) | actorHash == personHash -> return ()
|
||||||
_ -> throwE "Can't post activity attributed to someone else"
|
_ -> 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
|
case specific of
|
||||||
AP.AcceptActivity accept ->
|
AP.AcceptActivity accept -> run acceptC accept
|
||||||
acceptC eperson actorDB summary audience accept
|
AP.ApplyActivity apply -> run applyC apply
|
||||||
AP.ApplyActivity apply ->
|
|
||||||
applyC eperson actorDB mcap summary audience apply
|
|
||||||
AP.CreateActivity (AP.Create obj mtarget) ->
|
AP.CreateActivity (AP.Create obj mtarget) ->
|
||||||
case obj of
|
case obj of
|
||||||
{-
|
{-
|
||||||
|
@ -285,14 +318,13 @@ postPersonOutboxR personHash = do
|
||||||
createNoteC eperson sharer summary audience note mtarget
|
createNoteC eperson sharer summary audience note mtarget
|
||||||
-}
|
-}
|
||||||
AP.CreateTicketTracker detail mlocal ->
|
AP.CreateTicketTracker detail mlocal ->
|
||||||
createTicketTrackerC eperson actorDB summary audience detail mlocal mtarget
|
run createTicketTrackerC detail mlocal mtarget
|
||||||
AP.CreateRepository detail vcs mlocal ->
|
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 ->
|
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"
|
_ -> throwE "Unsupported Create 'object' type"
|
||||||
AP.InviteActivity invite ->
|
AP.InviteActivity invite -> run inviteC invite
|
||||||
inviteC eperson actorDB mcap summary audience invite
|
|
||||||
{-
|
{-
|
||||||
AddActivity (AP.Add obj target) ->
|
AddActivity (AP.Add obj target) ->
|
||||||
case obj of
|
case obj of
|
||||||
|
@ -306,8 +338,7 @@ postPersonOutboxR personHash = do
|
||||||
-}
|
-}
|
||||||
AP.OfferActivity (AP.Offer obj target) ->
|
AP.OfferActivity (AP.Offer obj target) ->
|
||||||
case obj of
|
case obj of
|
||||||
AP.OfferTicket ticket ->
|
AP.OfferTicket ticket -> run offerTicketC ticket target
|
||||||
offerTicketC eperson actorDB summary audience ticket target
|
|
||||||
{-
|
{-
|
||||||
OfferDep dep ->
|
OfferDep dep ->
|
||||||
offerDepC eperson sharer summary audience dep target
|
offerDepC eperson sharer summary audience dep target
|
||||||
|
@ -428,3 +459,6 @@ postPersonUnfollowR _ = error "Temporarily disabled"
|
||||||
|
|
||||||
postReplyR :: KeyHashid Message -> Handler ()
|
postReplyR :: KeyHashid Message -> Handler ()
|
||||||
postReplyR _ = error "Temporarily disabled"
|
postReplyR _ = error "Temporarily disabled"
|
||||||
|
|
||||||
|
getPersonStampR :: KeyHashid Person -> KeyHashid SigKey -> Handler TypedContent
|
||||||
|
getPersonStampR = servePerActorKey personActor LocalActorPerson
|
||||||
|
|
|
@ -44,6 +44,7 @@ module Vervis.Handler.Repo
|
||||||
|
|
||||||
, postRepoLinkR
|
, postRepoLinkR
|
||||||
|
|
||||||
|
, getRepoStampR
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
@ -432,9 +433,11 @@ postRepoNewR = do
|
||||||
personEntity@(Entity personID person) <- requireAuth
|
personEntity@(Entity personID person) <- requireAuth
|
||||||
personHash <- encodeKeyHashid personID
|
personHash <- encodeKeyHashid personID
|
||||||
(maybeSummary, audience, detail) <- C.createRepo personHash name desc
|
(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
|
actor <- runDB $ getJust $ personActor person
|
||||||
result <-
|
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
|
case result of
|
||||||
Left e -> do
|
Left e -> do
|
||||||
|
@ -702,6 +705,9 @@ postRepoLinkR repoHash loomHash = do
|
||||||
Right () -> setMessage "Repo successfully linked with loom!"
|
Right () -> setMessage "Repo successfully linked with loom!"
|
||||||
redirect $ RepoR repoHash
|
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]
|
update ticketID [Ticket495Title =. plain]
|
||||||
-- 496
|
-- 496
|
||||||
, addFieldPrimRequired "Bundle" False "auto"
|
, 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
|
migrateDB
|
||||||
|
|
|
@ -298,6 +298,7 @@ import Database.Persist.Sql (SqlBackend)
|
||||||
import Text.Email.Validate (EmailAddress)
|
import Text.Email.Validate (EmailAddress)
|
||||||
import Web.Text (HTML, PandocMarkdown)
|
import Web.Text (HTML, PandocMarkdown)
|
||||||
|
|
||||||
|
import Crypto.ActorKey
|
||||||
import Development.PatchMediaType
|
import Development.PatchMediaType
|
||||||
import Development.PatchMediaType.Persist
|
import Development.PatchMediaType.Persist
|
||||||
|
|
||||||
|
@ -669,3 +670,9 @@ model_494_mr_origin = $(schema "494_2022-09-17_mr_origin")
|
||||||
|
|
||||||
makeEntitiesMigration "495"
|
makeEntitiesMigration "495"
|
||||||
$(modelFile "migrations/495_2022-09-21_ticket_title.model")
|
$(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 Database.Persist.Schema.TH hiding (modelFile)
|
||||||
import Yesod.Auth.Account (PersistUserCredentials (..))
|
import Yesod.Auth.Account (PersistUserCredentials (..))
|
||||||
|
|
||||||
|
import Crypto.ActorKey
|
||||||
import Crypto.PublicVerifKey
|
import Crypto.PublicVerifKey
|
||||||
import Database.Persist.EmailAddress
|
import Database.Persist.EmailAddress
|
||||||
import Database.Persist.Graph.Class
|
import Database.Persist.Graph.Class
|
||||||
|
|
|
@ -18,25 +18,44 @@ module Vervis.Persist.Actor
|
||||||
, verifyLocalActivityExistsInDB
|
, verifyLocalActivityExistsInDB
|
||||||
, getRemoteActorURI
|
, getRemoteActorURI
|
||||||
, insertActor
|
, insertActor
|
||||||
|
, updateOutboxItem
|
||||||
|
, fillPerActorKeys
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
import Control.Monad.IO.Class
|
import Control.Monad.IO.Class
|
||||||
|
import Control.Monad.Logger.CallStack
|
||||||
import Control.Monad.Trans.Class
|
import Control.Monad.Trans.Class
|
||||||
import Control.Monad.Trans.Except
|
import Control.Monad.Trans.Except
|
||||||
import Control.Monad.Trans.Reader
|
import Control.Monad.Trans.Reader
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
|
import Data.Traversable
|
||||||
import Database.Persist
|
import Database.Persist
|
||||||
import Database.Persist.Sql
|
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 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 Control.Monad.Trans.Except.Local
|
||||||
import Database.Persist.Local
|
import Database.Persist.Local
|
||||||
|
|
||||||
|
import Vervis.Data.Actor
|
||||||
|
import Vervis.FedURI
|
||||||
|
import Vervis.Foundation
|
||||||
import Vervis.Model
|
import Vervis.Model
|
||||||
import Vervis.Recipient
|
import Vervis.Recipient
|
||||||
|
import Vervis.Settings
|
||||||
|
|
||||||
getLocalActor
|
getLocalActor
|
||||||
:: MonadIO m => ActorId -> ReaderT SqlBackend m (LocalActorBy Key)
|
:: MonadIO m => ActorId -> ReaderT SqlBackend m (LocalActorBy Key)
|
||||||
|
@ -93,3 +112,35 @@ insertActor now name desc = do
|
||||||
}
|
}
|
||||||
actorID <- insert actor
|
actorID <- insert actor
|
||||||
return $ Entity actorID 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.
|
{- 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.
|
- ♡ 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
|
-- How often to generate a new actor key for making HTTP signatures
|
||||||
, appActorKeyRotation :: TimeInterval
|
, appActorKeyRotation :: TimeInterval
|
||||||
|
-- | Whether to use personal actor keys, or an instance-wide key
|
||||||
|
, appPerActorKeys :: Bool
|
||||||
|
|
||||||
-- | Use detailed request logging system
|
-- | Use detailed request logging system
|
||||||
, appDetailedRequestLogging :: Bool
|
, appDetailedRequestLogging :: Bool
|
||||||
|
@ -224,6 +226,7 @@ instance FromJSON AppSettings where
|
||||||
|
|
||||||
appHttpSigTimeLimit <- interval <$> o .: "request-time-limit"
|
appHttpSigTimeLimit <- interval <$> o .: "request-time-limit"
|
||||||
appActorKeyRotation <- interval <$> o .: "actor-key-rotation"
|
appActorKeyRotation <- interval <$> o .: "actor-key-rotation"
|
||||||
|
appPerActorKeys <- o .:? "per-actor-keys" .!= False
|
||||||
|
|
||||||
appDetailedRequestLogging <- o .:? "detailed-logging" .!= defaultDev
|
appDetailedRequestLogging <- o .:? "detailed-logging" .!= defaultDev
|
||||||
appShouldLogAll <- o .:? "should-log-all" .!= defaultDev
|
appShouldLogAll <- o .:? "should-log-all" .!= defaultDev
|
||||||
|
|
|
@ -22,6 +22,8 @@ module Vervis.Web.Actor
|
||||||
, getActorFollowersCollection
|
, getActorFollowersCollection
|
||||||
, getFollowingCollection
|
, getFollowingCollection
|
||||||
, handleRobotInbox
|
, handleRobotInbox
|
||||||
|
, serveInstanceKey
|
||||||
|
, servePerActorKey
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
|
@ -69,6 +71,7 @@ import qualified Data.Text.Lazy as TL
|
||||||
import qualified Data.Vector as V
|
import qualified Data.Vector as V
|
||||||
import qualified Database.Esqueleto as E
|
import qualified Database.Esqueleto as E
|
||||||
|
|
||||||
|
import Crypto.ActorKey
|
||||||
import Database.Persist.JSON
|
import Database.Persist.JSON
|
||||||
import Network.FedURI
|
import Network.FedURI
|
||||||
import Web.ActivityPub hiding (Project (..), ActorLocal (..))
|
import Web.ActivityPub hiding (Project (..), ActorLocal (..))
|
||||||
|
@ -89,10 +92,11 @@ import Database.Persist.Local
|
||||||
import Yesod.Persist.Local
|
import Yesod.Persist.Local
|
||||||
|
|
||||||
import qualified Data.Aeson.Encode.Pretty.ToEncoding as P
|
import qualified Data.Aeson.Encode.Pretty.ToEncoding as P
|
||||||
|
import qualified Web.ActivityPub as AP
|
||||||
|
|
||||||
import Vervis.ActivityPub
|
import Vervis.ActivityPub
|
||||||
import Vervis.ActorKey
|
|
||||||
import Vervis.API
|
import Vervis.API
|
||||||
|
import Vervis.Data.Actor
|
||||||
import Vervis.FedURI
|
import Vervis.FedURI
|
||||||
import Vervis.Federation.Auth
|
import Vervis.Federation.Auth
|
||||||
import Vervis.Foundation
|
import Vervis.Foundation
|
||||||
|
@ -489,3 +493,63 @@ handleRobotInbox recipByHash handleSpecific now auth body = do
|
||||||
msig <- checkForwarding recipByHash
|
msig <- checkForwarding recipByHash
|
||||||
let mfwd = (localRecips,) <$> msig
|
let mfwd = (localRecips,) <$> msig
|
||||||
handleSpecific now remoteAuthor body mfwd luActivity (activitySpecific $ actbActivity body)
|
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 (..)
|
, Undo (..)
|
||||||
, Audience (..)
|
, Audience (..)
|
||||||
, SpecificActivity (..)
|
, SpecificActivity (..)
|
||||||
|
, Action (..)
|
||||||
|
, makeActivity
|
||||||
, Activity (..)
|
, Activity (..)
|
||||||
|
|
||||||
-- * Utilities
|
-- * Utilities
|
||||||
|
@ -92,8 +94,13 @@ module Web.ActivityPub
|
||||||
, hActivityPubForwarder
|
, hActivityPubForwarder
|
||||||
, hForwardingSignature
|
, hForwardingSignature
|
||||||
, hForwardedSignature
|
, hForwardedSignature
|
||||||
, httpPostAP
|
, Envelope ()
|
||||||
, httpPostAPBytes
|
, Errand ()
|
||||||
|
, sending
|
||||||
|
, retrying
|
||||||
|
, deliver
|
||||||
|
, forwarding
|
||||||
|
, forward
|
||||||
, Fetched (..)
|
, Fetched (..)
|
||||||
, fetchAP
|
, fetchAP
|
||||||
, fetchAP_T
|
, fetchAP_T
|
||||||
|
@ -115,6 +122,7 @@ import Control.Applicative ((<|>), optional)
|
||||||
import Control.Exception (Exception, displayException, try)
|
import Control.Exception (Exception, displayException, try)
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
import Control.Monad.IO.Class
|
import Control.Monad.IO.Class
|
||||||
|
import Control.Monad.Trans.Class
|
||||||
import Control.Monad.Trans.Except
|
import Control.Monad.Trans.Except
|
||||||
import Control.Monad.Trans.Writer (Writer)
|
import Control.Monad.Trans.Writer (Writer)
|
||||||
import Crypto.Hash hiding (Context)
|
import Crypto.Hash hiding (Context)
|
||||||
|
@ -132,7 +140,7 @@ import Data.Proxy
|
||||||
import Data.Semigroup (Endo, First (..))
|
import Data.Semigroup (Endo, First (..))
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
import Data.Text.Encoding (encodeUtf8, decodeUtf8, decodeUtf8')
|
import Data.Text.Encoding (encodeUtf8, decodeUtf8, decodeUtf8')
|
||||||
import Data.Time.Clock (UTCTime)
|
import Data.Time.Clock
|
||||||
import Data.Traversable
|
import Data.Traversable
|
||||||
import Network.HTTP.Client hiding (Proxy, proxy)
|
import Network.HTTP.Client hiding (Proxy, proxy)
|
||||||
import Network.HTTP.Client.Conduit.ActivityPub (httpAPEither)
|
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.HashMap.Strict as M
|
||||||
import qualified Data.List.NonEmpty as NE
|
import qualified Data.List.NonEmpty as NE
|
||||||
import qualified Data.Text as T
|
import qualified Data.Text as T
|
||||||
|
import qualified Data.Text.Encoding as TE
|
||||||
import qualified Data.Vector as V
|
import qualified Data.Vector as V
|
||||||
import qualified Network.HTTP.Signature as S
|
import qualified Network.HTTP.Signature as S
|
||||||
import qualified Text.Email.Parser as E
|
import qualified Text.Email.Parser as E
|
||||||
|
@ -1679,6 +1688,25 @@ data SpecificActivity u
|
||||||
| ResolveActivity (Resolve u)
|
| ResolveActivity (Resolve u)
|
||||||
| UndoActivity (Undo 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
|
data Activity u = Activity
|
||||||
{ activityId :: Maybe LocalURI
|
{ activityId :: Maybe LocalURI
|
||||||
, activityActor :: LocalURI
|
, activityActor :: LocalURI
|
||||||
|
@ -1855,62 +1883,168 @@ hForwardedSignature = "Forwarded-Signature"
|
||||||
-- * Compute HTTP signature and add _Signature_ request header
|
-- * Compute HTTP signature and add _Signature_ request header
|
||||||
-- * Perform the POST request
|
-- * Perform the POST request
|
||||||
-- * Verify the response status is 2xx
|
-- * Verify the response status is 2xx
|
||||||
|
{-
|
||||||
httpPostAP
|
httpPostAP
|
||||||
:: (MonadIO m, UriMode u, ToJSON a)
|
:: (MonadIO m, UriMode u, ToJSON a)
|
||||||
=> Manager
|
=> Manager
|
||||||
-> ObjURI u
|
|
||||||
-> NonEmpty HeaderName
|
-> NonEmpty HeaderName
|
||||||
-> S.KeyId
|
-> S.KeyId
|
||||||
-> (ByteString -> S.Signature)
|
-> (ByteString -> S.Signature)
|
||||||
-> Text
|
-> Text
|
||||||
-> Maybe (Either (ObjURI u) ByteString)
|
|
||||||
-> a
|
-> a
|
||||||
|
-> ObjURI u
|
||||||
|
-> Maybe (Either (ObjURI u) ByteString)
|
||||||
-> m (Either APPostError (Response ()))
|
-> m (Either APPostError (Response ()))
|
||||||
httpPostAP manager uri headers keyid sign uSender mfwd value =
|
httpPostAP manager headers keyid sign uSender value =
|
||||||
httpPostAPBytes manager uri headers keyid sign uSender mfwd $ encode 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
|
-- | Like 'httpPostAP', except it takes the object as a raw lazy
|
||||||
-- 'BL.ByteString'. It's your responsibility to make sure it's valid JSON.
|
-- 'BL.ByteString'. It's your responsibility to make sure it's valid JSON.
|
||||||
httpPostAPBytes
|
httpPostAPBytes
|
||||||
:: (MonadIO m, UriMode u)
|
:: (MonadIO m, UriMode u)
|
||||||
=> Manager
|
=> Manager
|
||||||
-> ObjURI u
|
|
||||||
-> NonEmpty HeaderName
|
-> NonEmpty HeaderName
|
||||||
-> S.KeyId
|
-> RefURI u
|
||||||
-> (ByteString -> S.Signature)
|
-> (ByteString -> S.Signature)
|
||||||
-> Text
|
-> Maybe LocalURI
|
||||||
-> Maybe (Either (ObjURI u) ByteString)
|
|
||||||
-> BL.ByteString
|
-> BL.ByteString
|
||||||
|
-> ForwardMode u
|
||||||
|
-> ObjURI u
|
||||||
-> m (Either APPostError (Response ()))
|
-> 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
|
liftIO $ runExceptT $ do
|
||||||
req <- requestFromURI $ uriFromObjURI uri
|
req <- requestFromURI $ uriFromObjURI uInbox
|
||||||
let digest = formatHttpBodyDigest SHA256 "SHA-256" $ hashlazy body
|
let digest = formatHttpBodyDigest SHA256 "SHA-256" $ hashlazy body
|
||||||
req' =
|
req' =
|
||||||
setRequestCheckStatus $
|
setRequestCheckStatus $
|
||||||
consHeader hContentType typeActivityStreams2LD $
|
consHeader hContentType typeActivityStreams2LD $
|
||||||
consHeader hActivityPubActor (encodeUtf8 uSender) $
|
maybe id (consHeader hActivityPubActor . TE.encodeUtf8 . renderObjURI . ObjURI hKey) mluHolder $
|
||||||
consHeader hDigest digest $
|
consHeader hDigest digest $
|
||||||
req { method = "POST"
|
req { method = "POST"
|
||||||
, requestBody = RequestBodyLBS body
|
, 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''' <-
|
req''' <-
|
||||||
case mfwd of
|
case fwd of
|
||||||
Nothing -> return req''
|
SendNoForward -> return req''
|
||||||
Just (Left uRecip) ->
|
SendAllowForward luRecip ->
|
||||||
tryExceptT APPostErrorSig $
|
except $ first APPostErrorSig $
|
||||||
signRequestInto hForwardingSignature (hDigest :| [hActivityPubForwarder]) Nothing keyid sign Nothing $ consHeader hActivityPubForwarder (encodeUtf8 $ renderObjURI uRecip) req''
|
signRequestInto hForwardingSignature (hDigest :| [hActivityPubForwarder]) Nothing keyid sign now $
|
||||||
Just (Right sig) ->
|
consHeader hActivityPubForwarder (encodeUtf8 $ renderObjURI $ ObjURI hInbox luRecip) req''
|
||||||
|
ForwardBy uSender sig ->
|
||||||
return $
|
return $
|
||||||
consHeader hForwardedSignature sig $
|
consHeader hForwardedSignature sig $
|
||||||
consHeader hActivityPubForwarder (encodeUtf8 uSender)
|
consHeader hActivityPubForwarder (encodeUtf8 $ renderObjURI uSender)
|
||||||
req''
|
req''
|
||||||
tryExceptT APPostErrorHTTP $ httpNoBody req''' manager
|
tryExceptT APPostErrorHTTP $ httpNoBody req''' manager
|
||||||
where
|
where
|
||||||
consHeader n b r = r { requestHeaders = (n, b) : requestHeaders r }
|
consHeader n b r = r { requestHeaders = (n, b) : requestHeaders r }
|
||||||
tryExceptT adapt action = ExceptT $ first adapt <$> try action
|
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.
|
-- | Result of GETing the keyId URI and processing the JSON document.
|
||||||
data Fetched = Fetched
|
data Fetched = Fetched
|
||||||
{ fetchedPublicKey :: PublicVerifKey
|
{ fetchedPublicKey :: PublicVerifKey
|
||||||
|
|
|
@ -1,6 +1,6 @@
|
||||||
{- This file is part of Vervis.
|
{- 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.
|
- ♡ Copying is an act of love. Please copy, reuse and share.
|
||||||
-
|
-
|
||||||
|
@ -15,22 +15,33 @@
|
||||||
|
|
||||||
module Yesod.ActivityPub
|
module Yesod.ActivityPub
|
||||||
( YesodActivityPub (..)
|
( YesodActivityPub (..)
|
||||||
|
|
||||||
|
, prepareToSend
|
||||||
|
, prepareToRetry
|
||||||
, deliverActivity
|
, deliverActivity
|
||||||
, deliverActivityBL
|
, deliverActivityExcept
|
||||||
, deliverActivityBL'
|
, deliverActivityThrow
|
||||||
|
|
||||||
|
, prepareToForward
|
||||||
, forwardActivity
|
, forwardActivity
|
||||||
|
, forwardActivityExcept
|
||||||
|
, forwardActivityThrow
|
||||||
|
|
||||||
, redirectToPrettyJSON
|
, redirectToPrettyJSON
|
||||||
|
|
||||||
, provideHtmlAndAP
|
, provideHtmlAndAP
|
||||||
, provideHtmlAndAP'
|
, provideHtmlAndAP'
|
||||||
, provideHtmlAndAP''
|
, provideHtmlAndAP''
|
||||||
, provideHtmlFeedAndAP
|
, provideHtmlFeedAndAP
|
||||||
|
|
||||||
, hostIsLocal
|
, hostIsLocal
|
||||||
, verifyHostLocal
|
, verifyHostLocal
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
import Control.Exception
|
import Control.Exception.Base
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
|
import Control.Monad.IO.Class
|
||||||
import Control.Monad.Logger.CallStack
|
import Control.Monad.Logger.CallStack
|
||||||
import Control.Monad.Trans.Except
|
import Control.Monad.Trans.Except
|
||||||
import Control.Monad.Trans.Writer
|
import Control.Monad.Trans.Writer
|
||||||
|
@ -56,6 +67,8 @@ import qualified Data.Text as T
|
||||||
|
|
||||||
import Network.HTTP.Signature
|
import Network.HTTP.Signature
|
||||||
|
|
||||||
|
import qualified Network.HTTP.Signature as S
|
||||||
|
|
||||||
import Database.Persist.JSON
|
import Database.Persist.JSON
|
||||||
import Network.FedURI
|
import Network.FedURI
|
||||||
import Web.ActivityPub
|
import Web.ActivityPub
|
||||||
|
@ -63,18 +76,307 @@ import Yesod.FedURI
|
||||||
import Yesod.MonadSite
|
import Yesod.MonadSite
|
||||||
import Yesod.RenderSource
|
import Yesod.RenderSource
|
||||||
|
|
||||||
|
import qualified Web.ActivityPub as AP
|
||||||
|
|
||||||
class (Yesod site, SiteFedURI site) => YesodActivityPub site where
|
class (Yesod site, SiteFedURI site) => YesodActivityPub site where
|
||||||
siteInstanceHost :: site -> Authority (SiteFedURIMode site)
|
siteInstanceHost :: site -> Authority (SiteFedURIMode site)
|
||||||
sitePostSignedHeaders :: site -> NonEmpty HeaderName
|
sitePostSignedHeaders :: site -> NonEmpty HeaderName
|
||||||
|
{-
|
||||||
siteGetHttpSign :: (MonadSite m, SiteEnv m ~ site)
|
siteGetHttpSign :: (MonadSite m, SiteEnv m ~ site)
|
||||||
=> m (KeyId, ByteString -> Signature)
|
=> m (KeyId, ByteString -> Signature)
|
||||||
{-
|
|
||||||
siteSigVerRequiredHeaders :: site -> [HeaderName]
|
siteSigVerRequiredHeaders :: site -> [HeaderName]
|
||||||
siteSigVerWantedHeaders :: site -> [HeaderName]
|
siteSigVerWantedHeaders :: site -> [HeaderName]
|
||||||
siteSigVerSeconds :: site -> Int
|
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
|
:: ( MonadSite m
|
||||||
, SiteEnv m ~ site
|
, SiteEnv m ~ site
|
||||||
, SiteFedURIMode site ~ u
|
, SiteFedURIMode site ~ u
|
||||||
|
@ -83,13 +385,15 @@ deliverActivity'
|
||||||
)
|
)
|
||||||
=> ObjURI u
|
=> ObjURI u
|
||||||
-> Maybe (ObjURI u)
|
-> Maybe (ObjURI u)
|
||||||
-> Text
|
-> Stamp
|
||||||
-> BL.ByteString
|
-> BL.ByteString
|
||||||
-> m (Either APPostError (Response ()))
|
-> m (Either APPostError (Response ()))
|
||||||
deliverActivity' inbox mfwd sender body = do
|
deliverActivityBL inbox mfwd (Stamp actorR keyR sign) body = do
|
||||||
manager <- asksSite getHttpManager
|
manager <- asksSite getHttpManager
|
||||||
headers <- asksSite sitePostSignedHeaders
|
headers <- asksSite sitePostSignedHeaders
|
||||||
(keyid, sign) <- siteGetHttpSign
|
(sender, keyid) <- do
|
||||||
|
renderUrl <- askUrlRender
|
||||||
|
return (renderUrl actorR, KeyId $ renderUrl keyR)
|
||||||
result <-
|
result <-
|
||||||
httpPostAPBytes
|
httpPostAPBytes
|
||||||
manager inbox headers keyid sign sender (Left <$> mfwd) body
|
manager inbox headers keyid sign sender (Left <$> mfwd) body
|
||||||
|
@ -115,48 +419,24 @@ deliverActivity
|
||||||
)
|
)
|
||||||
=> ObjURI u
|
=> ObjURI u
|
||||||
-> Maybe (ObjURI u)
|
-> Maybe (ObjURI u)
|
||||||
-> Doc Activity u
|
-> Envelope site
|
||||||
-> m (Either APPostError (Response ()))
|
-> m (Either APPostError (Response ()))
|
||||||
deliverActivity inbox mfwd doc@(Doc hAct activity) =
|
deliverActivity inbox mfwd (Envelope action idR actorR keyR sign) = do
|
||||||
let sender = renderObjURI $ ObjURI hAct (activityActor activity)
|
encodeRouteLocal <- getEncodeRouteLocal
|
||||||
body = encode doc
|
hLocal <- asksSite siteInstanceHost
|
||||||
in deliverActivity' inbox mfwd sender body
|
let body =
|
||||||
|
encode $ Doc hLocal $
|
||||||
|
makeActivity
|
||||||
|
(encodeRouteLocal idR) (encodeRouteLocal actorR) action
|
||||||
|
deliverActivityBL inbox mfwd (Stamp actorR keyR sign) body
|
||||||
|
|
||||||
deliverActivityBL
|
data Errand site = Errand
|
||||||
:: ( MonadSite m
|
{ errandDoc :: BL.ByteString
|
||||||
, SiteEnv m ~ site
|
, errandProof :: ByteString
|
||||||
, SiteFedURIMode site ~ u
|
, errandActor :: Route site
|
||||||
, HasHttpManager site
|
, errandKey :: Route site
|
||||||
, YesodActivityPub site
|
, errandSign :: ByteString -> Signature
|
||||||
)
|
}
|
||||||
=> 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
|
|
||||||
|
|
||||||
forwardActivity
|
forwardActivity
|
||||||
:: ( MonadSite m
|
:: ( MonadSite m
|
||||||
|
@ -166,18 +446,16 @@ forwardActivity
|
||||||
, YesodActivityPub site
|
, YesodActivityPub site
|
||||||
)
|
)
|
||||||
=> ObjURI u
|
=> ObjURI u
|
||||||
-> ByteString
|
-> Errand site
|
||||||
-> Route site
|
|
||||||
-> BL.ByteString
|
|
||||||
-> m (Either APPostError (Response ()))
|
-> 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
|
manager <- asksSite getHttpManager
|
||||||
headers <- asksSite sitePostSignedHeaders
|
headers <- asksSite sitePostSignedHeaders
|
||||||
(keyid, sign) <- siteGetHttpSign
|
let uActor = encodeRouteHome actorR
|
||||||
renderUrl <- askUrlRender
|
lruKey = LocalRefURI $ Left $ encodeRouteLocal keyR
|
||||||
let sender = renderUrl rSender
|
result <- AP.forward manager headers uActor lruKey sign doc inbox sig
|
||||||
result <-
|
|
||||||
httpPostAPBytes manager inbox headers keyid sign sender (Just $ Right sig) body
|
|
||||||
case result of
|
case result of
|
||||||
Left err ->
|
Left err ->
|
||||||
logError $ T.concat
|
logError $ T.concat
|
||||||
|
@ -190,6 +468,7 @@ forwardActivity inbox sig rSender body = do
|
||||||
, "> success: ", T.pack $ show $ responseStatus resp
|
, "> success: ", T.pack $ show $ responseStatus resp
|
||||||
]
|
]
|
||||||
return result
|
return result
|
||||||
|
-}
|
||||||
|
|
||||||
redirectToPrettyJSON
|
redirectToPrettyJSON
|
||||||
:: (MonadHandler m, HandlerSite m ~ site) => Route site -> m a
|
:: (MonadHandler m, HandlerSite m ~ site) => Route site -> m a
|
||||||
|
|
37
th/models
37
th/models
|
@ -118,6 +118,12 @@ Actor
|
||||||
UniqueActorOutbox outbox
|
UniqueActorOutbox outbox
|
||||||
UniqueActorFollowers followers
|
UniqueActorFollowers followers
|
||||||
|
|
||||||
|
SigKey
|
||||||
|
actor ActorId
|
||||||
|
material ActorKey
|
||||||
|
|
||||||
|
UniqueSigKey actor
|
||||||
|
|
||||||
Person
|
Person
|
||||||
username Username
|
username Username
|
||||||
login Text
|
login Text
|
||||||
|
@ -161,40 +167,11 @@ Forwarding
|
||||||
activity RemoteActivityId
|
activity RemoteActivityId
|
||||||
activityRaw ByteString
|
activityRaw ByteString
|
||||||
signature ByteString
|
signature ByteString
|
||||||
|
forwarder ActorId
|
||||||
running Bool
|
running Bool
|
||||||
|
|
||||||
UniqueForwarding recipient activity
|
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
|
/reply/#MessageKeyHashid ReplyR POST
|
||||||
|
|
||||||
|
/people/#PersonKeyHashid/stamps/#SigKeyKeyHashid PersonStampR GET
|
||||||
|
|
||||||
---- Group ------------------------------------------------------------------
|
---- Group ------------------------------------------------------------------
|
||||||
|
|
||||||
/groups/#GroupKeyHashid GroupR GET
|
/groups/#GroupKeyHashid GroupR GET
|
||||||
|
@ -158,6 +160,8 @@
|
||||||
/groups/#GroupKeyHashid/outbox/#OutboxItemKeyHashid GroupOutboxItemR GET
|
/groups/#GroupKeyHashid/outbox/#OutboxItemKeyHashid GroupOutboxItemR GET
|
||||||
/groups/#GroupKeyHashid/followers GroupFollowersR GET
|
/groups/#GroupKeyHashid/followers GroupFollowersR GET
|
||||||
|
|
||||||
|
/groups/#GroupKeyHashid/stamps/#SigKeyKeyHashid GroupStampR GET
|
||||||
|
|
||||||
---- Repo --------------------------------------------------------------------
|
---- Repo --------------------------------------------------------------------
|
||||||
|
|
||||||
/repos/#RepoKeyHashid RepoR GET
|
/repos/#RepoKeyHashid RepoR GET
|
||||||
|
@ -186,6 +190,8 @@
|
||||||
|
|
||||||
/repos/#RepoKeyHashid/enable-loom/#LoomKeyHashid RepoLinkR POST
|
/repos/#RepoKeyHashid/enable-loom/#LoomKeyHashid RepoLinkR POST
|
||||||
|
|
||||||
|
/repos/#RepoKeyHashid/stamps/#SigKeyKeyHashid RepoStampR GET
|
||||||
|
|
||||||
---- Deck --------------------------------------------------------------------
|
---- Deck --------------------------------------------------------------------
|
||||||
|
|
||||||
/decks/#DeckKeyHashid DeckR GET
|
/decks/#DeckKeyHashid DeckR GET
|
||||||
|
@ -203,6 +209,8 @@
|
||||||
/decks/#DeckKeyHashid/follow DeckFollowR POST
|
/decks/#DeckKeyHashid/follow DeckFollowR POST
|
||||||
/decks/#DeckKeyHashid/unfollow DeckUnfollowR POST
|
/decks/#DeckKeyHashid/unfollow DeckUnfollowR POST
|
||||||
|
|
||||||
|
/decks/#DeckKeyHashid/stamps/#SigKeyKeyHashid DeckStampR GET
|
||||||
|
|
||||||
---- Ticket ------------------------------------------------------------------
|
---- Ticket ------------------------------------------------------------------
|
||||||
|
|
||||||
/decks/#DeckKeyHashid/tickets/#TicketDeckKeyHashid TicketR GET
|
/decks/#DeckKeyHashid/tickets/#TicketDeckKeyHashid TicketR GET
|
||||||
|
@ -248,6 +256,8 @@
|
||||||
/looms/#LoomKeyHashid/follow LoomFollowR POST
|
/looms/#LoomKeyHashid/follow LoomFollowR POST
|
||||||
/looms/#LoomKeyHashid/unfollow LoomUnfollowR POST
|
/looms/#LoomKeyHashid/unfollow LoomUnfollowR POST
|
||||||
|
|
||||||
|
/looms/#LoomKeyHashid/stamps/#SigKeyKeyHashid LoomStampR GET
|
||||||
|
|
||||||
---- Cloth -------------------------------------------------------------------
|
---- Cloth -------------------------------------------------------------------
|
||||||
|
|
||||||
/looms/#LoomKeyHashid/cloths/#TicketLoomKeyHashid ClothR GET
|
/looms/#LoomKeyHashid/cloths/#TicketLoomKeyHashid ClothR GET
|
||||||
|
|
|
@ -46,6 +46,7 @@ library
|
||||||
Control.Concurrent.Local
|
Control.Concurrent.Local
|
||||||
Control.Concurrent.ResultShare
|
Control.Concurrent.ResultShare
|
||||||
Control.Monad.Trans.Except.Local
|
Control.Monad.Trans.Except.Local
|
||||||
|
Crypto.ActorKey
|
||||||
Crypto.PubKey.Encoding
|
Crypto.PubKey.Encoding
|
||||||
Crypto.PublicVerifKey
|
Crypto.PublicVerifKey
|
||||||
Darcs.Local.Repository
|
Darcs.Local.Repository
|
||||||
|
@ -127,7 +128,6 @@ library
|
||||||
|
|
||||||
Vervis.Access
|
Vervis.Access
|
||||||
Vervis.ActivityPub
|
Vervis.ActivityPub
|
||||||
Vervis.ActorKey
|
|
||||||
Vervis.API
|
Vervis.API
|
||||||
Vervis.Avatar
|
Vervis.Avatar
|
||||||
Vervis.BinaryBody
|
Vervis.BinaryBody
|
||||||
|
@ -144,7 +144,6 @@ library
|
||||||
Vervis.Data.Collab
|
Vervis.Data.Collab
|
||||||
Vervis.Data.Ticket
|
Vervis.Data.Ticket
|
||||||
|
|
||||||
Vervis.Delivery
|
|
||||||
Vervis.Discussion
|
Vervis.Discussion
|
||||||
--Vervis.Federation
|
--Vervis.Federation
|
||||||
Vervis.Federation.Auth
|
Vervis.Federation.Auth
|
||||||
|
@ -231,6 +230,7 @@ library
|
||||||
|
|
||||||
Vervis.Web.Actor
|
Vervis.Web.Actor
|
||||||
Vervis.Web.Darcs
|
Vervis.Web.Darcs
|
||||||
|
Vervis.Web.Delivery
|
||||||
Vervis.Web.Discussion
|
Vervis.Web.Discussion
|
||||||
Vervis.Web.Git
|
Vervis.Web.Git
|
||||||
Vervis.Web.Repo
|
Vervis.Web.Repo
|
||||||
|
|
Loading…
Reference in a new issue