From 621275e25762a1c1e5860d07a6ff87b147deed4f Mon Sep 17 00:00:00 2001
From: Pere Lev <pere@towards.vision>
Date: Tue, 30 May 2023 12:51:41 +0300
Subject: [PATCH] Verify integrity proof on remote activities coming into local
 inboxes

Limitations:

- Only jcs-eddsa-2022 is supported for now, can add more easily if
  needed
- Not verifying forwarded local activities, only remotely-authored ones
- Fetching key and actor with HTTP without using the DB cache, because
  the current cache system is deprecated and I haven't yet created the
  new one
---
 src/Vervis/Federation/Auth.hs | 54 +++++++++++++++++++++++++++++++++++
 1 file changed, 54 insertions(+)

diff --git a/src/Vervis/Federation/Auth.hs b/src/Vervis/Federation/Auth.hs
index de26208..7f09678 100644
--- a/src/Vervis/Federation/Auth.hs
+++ b/src/Vervis/Federation/Auth.hs
@@ -59,8 +59,12 @@ import UnliftIO.Exception (try)
 import Yesod.Core hiding (logError, logWarn, logInfo, logDebug)
 import Yesod.Persist.Core
 
+import qualified Data.Aeson as A
+import qualified Data.ByteString as B
+import qualified Data.ByteArray as BA
 import qualified Data.ByteString.Lazy as BL
 import qualified Data.CaseInsensitive as CI
+import qualified Data.HashMap.Strict as HM
 import qualified Data.List as L
 import qualified Data.List.NonEmpty as NE
 import qualified Data.List.Ordered as LO
@@ -85,6 +89,8 @@ import Yesod.FedURI
 import Yesod.Hashids
 import Yesod.MonadSite
 
+import qualified Web.ActivityPub as AP
+
 import Control.Monad.Trans.Except.Local
 import Data.Aeson.Local
 import Data.Either.Local
@@ -111,6 +117,47 @@ parseKeyId (KeyId k) =
         Left e -> throwE $ "keyId isn't a valid FedURI: " ++ e
         Right u -> return u
 
+-- Given a remote actor and key URIs.
+--
+-- Intended behavior:
+--
+-- * If we already have this actor and ket on our DB, grab from DB, verify key
+--   hasn't expired
+-- * Otherwise, fetch actor and key via HTTP, verify bidirectional link, verify
+--   key hasn't expired, and cache actor and key in DB for future use
+--
+-- Current behavior: Always use HTTP, no DB caching.
+--
+-- Why: Because I need to rewrite the whole caching system, switching from the
+-- PostgreSQL system with the ugly host locks into using an actor-oriented
+-- model. And even that is AP-specific, so, might skip that for now and resume
+-- when moving from AP to CapTP.
+getActorKey
+    :: Host -> LocalURI -> LocalRefURI -> ExceptT Text Handler PublicVerifKey
+getActorKey host luActor lruKey = withExceptT T.pack $ do
+    manager <- getsYesod appHttpManager
+    key <- AP.fetchUnknownKey manager Nothing host (Just luActor) lruKey
+    for_ (AP.fetchedKeyExpires key) $ \ exp -> do
+        now <- liftIO getCurrentTime
+        unless (now < exp) $ throwE "Key has expired"
+    return $ AP.fetchedPublicKey key
+
+verifyIntegrityProof :: A.Object -> Host -> LocalURI -> AP.Proof URIMode -> ExceptT Text Handler ()
+verifyIntegrityProof object host luActor (AP.Proof config sig) =
+    nameExceptT "verifyIntegrityProof" $ do
+        key <- getActorKey host luActor (AP.proofKey config)
+        case key of
+            PublicVerifKeyEd25519 _ -> return ()
+            _ -> throwE "Only jcs-eddsa-2022 i.e. ed25519 keys are supported"
+        let objectNoProof = HM.delete "proof" object
+            configLB = A.encode $ Doc host config
+            bodyLB = A.encode objectNoProof
+            configHash = hashWith SHA256 $ BL.toStrict configLB
+            bodyHash = hashWith SHA256 $ BL.toStrict bodyLB
+            input = BA.convert configHash `B.append` BA.convert bodyHash
+        valid <- ExceptT . pure . first T.pack $ verifySignature key input sig
+        unless valid $ throwE "Proof signature verification didn't pass"
+
 verifyActorSig'
     :: Maybe Algorithm
     -> ByteString
@@ -405,6 +452,13 @@ authenticateActivity now = do
                         , renderAuthority hSender, ">"
                         ]
                     Just a -> return a
+
+    -- Verify FEP-8b32 jcs-eddsa-2022 VC data integrity proof
+    for_ (AP.activityProof activity) $ \ proof -> do
+        hl <- hostIsLocalOld hActivity
+        unless hl $
+            verifyIntegrityProof raw hActivity (activityActor activity) proof
+
     return (auth, ActivityBody body raw activity)
     where
     verifyBodyDigest = do