forge/Vervis
1
0
Fork 0
Code Pull requests Activity

Store remote actors' inbox URIs in DB, avoiding some actor fetch

Browse source 
When a local user wants to publish an activity, we were always GETing the
recipient actor, so that we could determine their inbox and POST the activity
to it. But now, instead, whenever we GET an actor (whether it's for the key sig
verification or for determining inbox URI), we keep their inbox URI in the
database, and we don't need to GET it again next time.
This commit is contained in:
fr33domlover 2019-02-14 23:27:40 +00:00
parent 128f1297ec
commit 9e0314fa09
5 changed files with 59 additions and 36 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
config/models
View file

@ -51,6 +51,7 @@ VerifKey
RemoteSharer
ident FedURI
instance InstanceId
inbox FedURI
UniqueRemoteSharer ident

1
migrations/2019_02_03_verifkey.model
View file

@ -10,6 +10,7 @@ VerifKey
RemoteSharer
ident Text
instance InstanceId
inbox Text
UniqueRemoteSharer ident

27
src/Vervis/Foundation.hs
View file

@ -22,6 +22,7 @@ import Control.Monad.Trans.Except
import Control.Monad.Trans.Maybe
import Crypto.Error (CryptoFailable (..))
import Crypto.PubKey.Ed25519 (publicKey, signature, verify)
import Data.Either (isRight)
import Data.Maybe (fromJust)
import Data.PEM (pemContent)
import Data.Text.Encoding (decodeUtf8')
@ -593,7 +594,7 @@ instance YesodHttpSig App where
t <- first displayException $ decodeUtf8' b
parseFedURI t
_ -> throwE "Multiple ActivityPub-Actor headers"
(mvkid, key, mexpires, uActor, host, shared) <- do
(inboxOrVkid, key, mexpires, uActor, host, shared) <- do
ments <- lift $ runDB $ do
mvk <- getBy $ UniqueVerifKey u
for mvk $ \ vk@(Entity _ verifkey) -> do
@ -610,7 +611,7 @@ instance YesodHttpSig App where
Just u -> return (u, True)
let uKey = verifKeyIdent vk
return
( Just vkid
( Right vkid
, verifKeyPublic vk
, verifKeyExpires vk
, ua
@ -618,12 +619,12 @@ instance YesodHttpSig App where
, s
)
Nothing -> do
Fetched k mexp ua h s <- fetchKey' muActorHeader u
return (Nothing, k, mexp, ua, h, s)
Fetched k mexp ua uinb h s <- fetchKey' muActorHeader u
return (Left uinb, k, mexp, ua, h, s)
let verify' k = verify k input signature
errSig = throwE "Ed25519 sig verification says not valid"
errTime = throwE "Key expired"
existsInDB = isJust mvkid
existsInDB = isRight inboxOrVkid
now <- liftIO getCurrentTime
let stillValid Nothing = True
stillValid (Just expires) = expires > now
@ -632,7 +633,7 @@ instance YesodHttpSig App where
then return (not existsInDB, key, mexpires)
else if existsInDB
then do
Fetched newKey newExp newActor h s <- fetchKey' muActorHeader u
Fetched newKey newExp newActor _newInbox h s <- fetchKey' muActorHeader u
if shared == s
then return ()
else throwE "Key scope changed, we reject that"
@ -653,8 +654,8 @@ instance YesodHttpSig App where
then errSig
else errTime
when write $ ExceptT $ runDB $
case mvkid of
Nothing ->
case inboxOrVkid of
Left inbox ->
if shared
then do
ment <- getBy $ UniqueInstance host
@ -674,12 +675,8 @@ instance YesodHttpSig App where
ment <- getBy $ UniqueRemoteSharer uActor
case ment of
Nothing -> do
iid <- do
ment2 <- getBy $ UniqueInstance host
case ment2 of
Nothing -> insert $ Instance host
Just (Entity i _) -> return i
rsid <- insert $ RemoteSharer uActor iid
iid <- either entityKey id <$> insertBy (Instance host)
rsid <- insert $ RemoteSharer uActor iid inbox
insert_ $ VerifKey u iid mexpires' key' (Just rsid)
return $ Right ()
Just (Entity rsid rs) -> do
@ -690,7 +687,7 @@ instance YesodHttpSig App where
insert_ $ VerifKey u iid mexpires' key' (Just rsid)
return $ Right ()
else return $ Left "We already store 2 keys"
Just vkid -> do
Right vkid -> do
update vkid
[VerifKeyExpires =. mexpires', VerifKeyPublic =. key']
return $ Right ()

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

@ -35,6 +35,7 @@ import Crypto.Error (CryptoFailable (..))
import Crypto.PubKey.Ed25519 (publicKey, signature, verify)
import Data.Aeson
import Data.Bifunctor (first, second)
import Data.Foldable (for_)
import Data.HashMap.Strict (HashMap)
import Data.List.NonEmpty (NonEmpty (..))
import Data.PEM (PEM (..))
@ -44,7 +45,7 @@ import Data.Text.Lazy.Encoding (decodeUtf8)
import Data.Time.Clock (UTCTime, getCurrentTime)
import Data.Time.Interval (TimeInterval, toTimeUnit)
import Data.Time.Units (Second)
import Database.Persist (Entity (..))
import Database.Persist (Entity (..), getBy, insertBy, insert_)
import Network.HTTP.Client (Manager, HttpException, requestFromURI)
import Network.HTTP.Simple (httpJSONEither, getResponseBody, setRequestManager, addRequestHeader)
import Network.HTTP.Types.Header (hDate, hHost)
@ -229,27 +230,47 @@ postOutboxR = do
}
}
manager <- getsYesod appHttpManager
eres <- httpGetAP manager to
case eres of
Left (APGetErrorHTTP e) -> setMessage $ toHtml $ "Failed to GET the recipient actor: " <> T.pack (displayException e)
Left (APGetErrorJSON e) -> setMessage $ toHtml $ "Failed to parse recipient actor JSON: " <> T.pack (displayException e)
Left (APGetErrorContentType e) -> setMessage $ toHtml $ "Got unexpected Content-Type for actor JSON: " <> e
Right response -> do
let actor = getResponseBody response
if actorId actor /= to
then setMessage "Fetched actor JSON but its id doesn't match the URL we fetched"
else do
(akey1, akey2, new1) <- liftIO . readTVarIO =<< getsYesod appActorKeys
let (keyID, akey) =
if new1
then (renderUrl ActorKey1R, akey1)
else (renderUrl ActorKey2R, akey2)
sign b = (KeyId $ encodeUtf8 keyID, actorKeySign akey b)
eres' <- httpPostAP manager (actorInbox actor) (hRequestTarget :| [hHost, hDate, hActivityPubActor]) sign actorID activity
case eres' of
Left e -> setMessage $ toHtml $ "Failed to POST to recipient's inbox: " <> T.pack (displayException e)
Right _ -> setMessage "Activity posted! You can go to the target server's /inbox to see the result."
minbox <- fetchInboxURI manager to
for_ minbox $ \ inbox -> do
(akey1, akey2, new1) <- liftIO . readTVarIO =<< getsYesod appActorKeys
let (keyID, akey) =
if new1
then (renderUrl ActorKey1R, akey1)
else (renderUrl ActorKey2R, akey2)
sign b = (KeyId $ encodeUtf8 keyID, actorKeySign akey b)
eres' <- httpPostAP manager inbox (hRequestTarget :| [hHost, hDate, hActivityPubActor]) sign actorID activity
case eres' of
Left e -> setMessage $ toHtml $ "Failed to POST to recipient's inbox: " <> T.pack (displayException e)
Right _ -> setMessage "Activity posted! You can go to the target server's /inbox to see the result."
defaultLayout $ activityWidget widget enctype
where
fetchInboxURI :: Manager -> FedURI -> Handler (Maybe FedURI)
fetchInboxURI manager to = do
mrs <- runDB $ getBy $ UniqueRemoteSharer to
case mrs of
Nothing -> do
eres <- httpGetAP manager to
case eres of
Left (APGetErrorHTTP e) -> do
setMessage $ toHtml $ "Failed to GET the recipient actor: " <> T.pack (displayException e)
return Nothing
Left (APGetErrorJSON e) -> do
setMessage $ toHtml $ "Failed to parse recipient actor JSON: " <> T.pack (displayException e)
return Nothing
Left (APGetErrorContentType e) -> do
setMessage $ toHtml $ "Got unexpected Content-Type for actor JSON: " <> e
return Nothing
Right response -> do
let actor = getResponseBody response
if actorId actor /= to
then setMessage "Fetched actor JSON but its id doesn't match the URL we fetched" >> return Nothing
else do
let inbox = actorInbox actor
runDB $ do
iid <- either entityKey id <$> insertBy (Instance $ furiHost to)
insert_ $ RemoteSharer to iid inbox
return $ Just inbox
Just (Entity _rsid rs) -> return $ Just $ remoteSharerInbox rs
getActorKey :: ((ActorKey, ActorKey, Bool) -> ActorKey) -> Route App -> Handler TypedContent
getActorKey choose route = do

3
src/Web/ActivityPub.hs
View file

@ -390,6 +390,8 @@ data Fetched = Fetched
-- ^ Optional expiration time declared for the key we received.
, fetchedActorId :: FedURI
-- ^ The @id URI of the actor for whom the key's signature applies.
, fetchedActorInbox :: FedURI
-- ^ The inbox URI of the actor for whom the key's signature applies.
, fetchedHost :: Text
-- ^ The domain name of the instance from which we got the key.
, fetchedKeyShared :: Bool
@ -484,6 +486,7 @@ fetchKey manager sigAlgo muActor uKey = runExceptT $ do
{ fetchedPublicKey = k
, fetchedKeyExpires = publicKeyExpires pkey
, fetchedActorId = actorId actor
, fetchedActorInbox = actorInbox actor
, fetchedHost = furiHost uKey
, fetchedKeyShared = shared
}