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

Improve the AP async HTTP delivery API and per-actor key support

Browse source 
New iteration of the ActivityPub delivery implementation and interface.
Advantages over previous interface:

* When sending a ByteString body, the sender is explicitly passed as a
  parameter instead of JSON-parsing it out of the ByteString
* Clear 3 operations provided: Send, Resend and Forward
* Support for per-actor keys
* Actor-type-specific functions (e.g. deliverRemoteDB_D) removed
* Only the most high-level API is exposed to Activity handler code, making
  handler code more concise and clear

Also added in this patch:

* Foundation for per-actor key support
* 1 key per actor allowed in DB
* Disabled C2S and S2S handlers now un-exported for clarity
* Audience and capability parsing automatically done for all C2S handlers
* Audience and activity composition automatically done for Vervis.Client
  builder functions

Caveats:

* Actor documents still don't link to their per-actor keys; that should be the
  last piece to complete per-actor key support
* No moderation and anti-spam tools yet
* Delivery API doesn't yet have good integration of persistence layer, e.g.
  activity is separately encoded into bytestring for DB and for HTTP; this will
  be improved in the next iteration
* Periodic delivery now done in 3 separate steps, running sequentially; it
  simplifies the code, but may be changed for efficiency/robustness in the next
  iterations
* Periodic delivery collects per-actor keys in a
  1-DB-transaction-for-each-delivery fashion, rather than grabbing them in the
  big Esqueleto query (or keeping the signed output in the DB; this isn't done
  currently to allow for smooth actor key renewal)
* No support yet in the API for delivery where the actor key has already been
  fetched, rather than doing a DB transaction to grab it; such support would be
  just an optimization, so it's low-priority, but will be added in later
  iterations
This commit is contained in:
fr33domlover 2022-10-12 16:50:11 +00:00
parent 3c7b9f33e4
commit 32c87e3839
36 changed files with 2197 additions and 1584 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3
config/settings-default.yaml
View file

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

@ -0,0 +1,5 @@
SigKey
actor ActorId
material ActorKey
UniqueSigKey actor

121
migrations/498_2022-10-03_forwarder.model Normal file
View 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

8
src/Vervis/ActorKey.hs → src/Crypto/ActorKey.hs
View file

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

6
src/Data/Tuple/Local.hs
View file

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

6
src/Network/FedURI.hs
View file

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

754
src/Vervis/API.hs
View file

File diff suppressed because it is too large Load diff

27
src/Vervis/Application.hs
View file

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

87
src/Vervis/Client.hs
View file

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

16
src/Vervis/Data/Actor.hs
View file

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

2
src/Vervis/Federation.hs
View file

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

112
src/Vervis/Federation/Auth.hs
View file

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

175
src/Vervis/Federation/Collab.hs
View file

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

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

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

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

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

2
src/Vervis/Fetch.hs
View file

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

17
src/Vervis/Foundation.hs
View file

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

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

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

9
src/Vervis/Handler/Cloth.hs
View file

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

7
src/Vervis/Handler/Deck.hs
View file

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

4
src/Vervis/Handler/Group.hs
View file

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

11
src/Vervis/Handler/Loom.hs
View file

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

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

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

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

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

50
src/Vervis/Migration.hs
View file

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

7
src/Vervis/Migration/Model.hs
View file

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

1
src/Vervis/Model.hs
View file

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

51
src/Vervis/Persist/Actor.hs
View file

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

5
src/Vervis/Settings.hs
View file

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

66
src/Vervis/Web/Actor.hs
View file

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

1024
src/Vervis/Delivery.hs → src/Vervis/Web/Delivery.hs
View file

File diff suppressed because it is too large Load diff

178
src/Web/ActivityPub.hs
View file

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

395
src/Yesod/ActivityPub.hs
View file

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

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

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

4
vervis.cabal
View file

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