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