Generate FEP-8b32 authenticity proofs when delivering activities

Limitations: - Verification of proofs not implemeneted yet, just generation. Verification probably coming in the next commit. - Only jcs-eddsa-2022 is supported. Can add more cryptosuites once they're updated for the requirements of the VC Data Integrity spec. - Bug: The proofs aren't stored in the DB versions of outgoing activities, i.e. HTTP GETing an activity won't include the proof. Probably not urgent to fix. Ideally, change the whole PersistJSONObject/Envelope/etc. thing to allow to serialize the activity exactly once.
2024-12-27 17:34:52 +09:00 · 2023-05-30 09:48:21 +03:00 · 2023-05-30 09:48:21 +03:00 · e8e587af26
commit e8e587af26
parent ba02d62eb5
11 changed files with 128 additions and 46 deletions
--- a/src/Crypto/ActorKey.hs
+++ b/src/Crypto/ActorKey.hs
@ -179,7 +179,7 @@ generateActorKey = mk <$> generateSecretKey
    -- renderPEM = pemWriteBS . PEM "PUBLIC KEY" [] . convert

 -- | A loop that runs forever and periodically generates new actor keys,
-- storing them in a 'TVar'. It manages a pait of keys, and each time it toggles
+-- storing them in a 'TVar'. It manages a pair of keys, and each time it toggles
 -- which key gets rotated.
 actorKeyRotator :: TimeInterval -> TVar (ActorKey, ActorKey, Bool) -> IO ()
 actorKeyRotator interval keys = periodically interval $ do
--- a/src/Vervis/API.hs
+++ b/src/Vervis/API.hs
@ -1174,6 +1174,7 @@ createPatchTrackerC (Entity pidUser personUser) senderActor maybeCap localRecips
                , activitySummary  = Nothing
                , activityAudience = AP.Audience recips [] [] [] [] []
                , activityFulfills = []
+                , activityProof    = Nothing
                , activitySpecific = FollowActivity AP.Follow
                    { AP.followObject  = encodeRouteHome $ LoomR loomHash
                    , AP.followContext = Nothing
@ -1198,6 +1199,7 @@ createPatchTrackerC (Entity pidUser personUser) senderActor maybeCap localRecips
                , activitySummary  = Nothing
                , activityAudience = Audience recips [] [] [] [] []
                , activityFulfills = []
+                , activityProof    = Nothing
                , activitySpecific = AcceptActivity Accept
                    { acceptObject = ObjURI hLocal luFollow
                    , acceptResult = Nothing
@ -1400,6 +1402,7 @@ createRepositoryC (Entity pidUser personUser) senderActor maybeCap localRecips r
                , activitySummary  = Nothing
                , activityAudience = AP.Audience recips [] [] [] [] []
                , activityFulfills = []
+                , activityProof    = Nothing
                , activitySpecific = FollowActivity AP.Follow
                    { AP.followObject  = encodeRouteHome $ RepoR repoHash
                    , AP.followContext = Nothing
@ -1424,6 +1427,7 @@ createRepositoryC (Entity pidUser personUser) senderActor maybeCap localRecips r
                , activitySummary  = Nothing
                , activityAudience = Audience recips [] [] [] [] []
                , activityFulfills = []
+                , activityProof    = Nothing
                , activitySpecific = AcceptActivity Accept
                    { acceptObject = ObjURI hLocal luFollow
                    , acceptResult = Nothing
@ -1652,6 +1656,7 @@ createTicketTrackerC (Entity pidUser personUser) senderActor maybeCap localRecip
                , activitySummary  = Nothing
                , activityAudience = AP.Audience recips [] [] [] [] []
                , activityFulfills = []
+                , activityProof    = Nothing
                , activitySpecific = FollowActivity AP.Follow
                    { AP.followObject  = encodeRouteHome $ DeckR deckHash
                    , AP.followContext = Nothing
@ -1676,6 +1681,7 @@ createTicketTrackerC (Entity pidUser personUser) senderActor maybeCap localRecip
                , activitySummary  = Nothing
                , activityAudience = Audience recips [] [] [] [] []
                , activityFulfills = []
+                , activityProof    = Nothing
                , activitySpecific = AcceptActivity Accept
                    { acceptObject = ObjURI hLocal luFollow
                    , acceptResult = Nothing
--- a/src/Vervis/Federation.hs
+++ b/src/Vervis/Federation.hs
@ -65,43 +65,6 @@ import qualified Data.Text as T
 import qualified Database.Esqueleto as E
 import qualified Network.Wai as W

-import Data.Time.Interval
-import Network.HTTP.Signature hiding (requestHeaders)
-import Yesod.HttpSignature
-
-import Crypto.PublicVerifKey
-import Database.Persist.JSON
-import Network.FedURI
-import Network.HTTP.Digest
-import Web.ActivityPub hiding (Follow, Ticket)
-import Yesod.ActivityPub
-import Yesod.Auth.Unverified
-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
-import Data.List.Local
-import Data.List.NonEmpty.Local
-import Data.Maybe.Local
-import Data.Tuple.Local
-import Database.Persist.Local
-import Yesod.Persist.Local
-
-import Vervis.ActivityPub
-import Vervis.ActorKey
-import Vervis.Web.Delivery
-import Vervis.Federation.Auth
-import Vervis.Foundation
-import Vervis.Model
-import Vervis.Recipient
-import Vervis.RemoteActorStore
-import Vervis.Settings
-
 {-

 handleProjectInbox
--- a/src/Vervis/Foundation.hs
+++ b/src/Vervis/Foundation.hs
@ -75,7 +75,7 @@ import qualified Network.HTTP.Signature as S (Algorithm (..))

 import Control.Concurrent.Actor hiding (Message)
 import Crypto.ActorKey
-import Crypto.PublicVerifKey
+--import Crypto.PublicVerifKey
 import Network.FedURI
 import Web.ActivityAccess
 import Web.Actor.Persist
--- a/src/Vervis/Handler/Person.hs
+++ b/src/Vervis/Handler/Person.hs
@ -193,7 +193,7 @@ postPersonOutboxR personHash = do
        unless (federation || null remoteRecips) $
            throwE "Federation disabled, but remote recipients found"

-    handle eperson actorDB (AP.Activity _mid _actorAP muCap summary audience _fulfills specific) = do
+    handle eperson actorDB (AP.Activity _mid _actorAP muCap summary audience _fulfills _mproof specific) = do
        maybeCap <- traverse (nameExceptT "Capability" . parseActivityURI) muCap
        ParsedAudience localRecips remoteRecips blinded fwdHosts <- do
            mrecips <- parseAudience audience
--- a/src/Vervis/Migration.hs
+++ b/src/Vervis/Migration.hs
@ -1,6 +1,6 @@
 {- This file is part of Vervis.
 -
- - Written in 2016, 2018, 2019, 2020, 2021, 2022
+ - Written in 2016, 2018, 2019, 2020, 2021, 2022, 2023
 - by fr33domlover <fr33domlover@riseup.net>.
 -
 - ♡ Copying is an act of love. Please copy, reuse and share.
@ -581,6 +581,7 @@ changes hLocal ctx =
                    , activitySummary  = Nothing
                    , activityAudience = Audience [] [] [] [] [] []
                    , activityFulfills = []
+                    , activityProof    = Nothing
                    , activitySpecific = RejectActivity $ Reject fedUri
                    }
            insertEntity $ OutboxItem20190612 pid (persistJSONObjectFromDoc doc) defaultTime
--- a/src/Web/ActivityPub.hs
+++ b/src/Web/ActivityPub.hs
@ -82,6 +82,8 @@ module Web.ActivityPub
    , Resolve (..)
    , Undo (..)
    , Audience (..)
+    , ProofConfig (..)
+    , Proof (..)
    , SpecificActivity (..)
    , activityType
    , Action (..)
@ -160,6 +162,9 @@ import Yesod.Core.Handler (ProvidedRep, provideRepType)
 import Network.HTTP.Client.Signature

 import qualified Data.Attoparsec.ByteString as A
+import qualified Data.ByteArray as BA
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Base58 as B58
 import qualified Data.ByteString.Base64 as B64
 import qualified Data.ByteString.Char8 as BC
 import qualified Data.ByteString.Lazy as BL
@ -180,6 +185,34 @@ import Web.Text

 import Data.Aeson.Local

+-- JSON CANONICALIZATION
+--
+-- In order to produce JSON-based sigs, we need the ability to produce a
+-- canonical ByteString from a given ToJSON-able object. Is aeson's encoder
+-- already compatible?
+--
+-- * Before aeson-2, clearly no, because a HashMap is used for objects
+-- * After aeson-2, possibly, since ordered-map mode exists and on by default
+--
+-- I'm gonna list requirements here and then we can compare this with aeson.
+--
+-- - [ ] JSON number data MUST be expressible as IEEE 754 [IEEE754]
+-- double-precision values. For applications needing higher precision or longer
+-- integers than offered by IEEE 754 double precision, it is RECOMMENDED to
+-- represent such numbers as JSON strings
+-- - [ ] objects must be sorted by key
+-- - [ ] The sorting process is applied to property name strings in their "raw" (unescaped) form. That is, a newline character is treated as U+000A
+-- - [ ] Property name strings to be sorted are formatted as arrays of UTF-16 [UNICODE] code units. The sorting is based on pure value comparisons, where code units are treated as unsigned integers, independent of locale settings
+--
+-- Looks like the primary things to verify are key ordering and number
+-- serialization.
+--
+-- When to encode? We need to encode the activity and then:
+--
+-- 1. Put it in the DB
+-- 2. Send to local actors via system
+-- 3. Send to remote actors via HTTP
+
 {-
 data Link = Link
    { linkHref      :: URI
@ -1857,6 +1890,57 @@ parseUndo a o = Undo <$> o .: "object"
 encodeUndo :: UriMode u => Authority u -> Undo u -> Series
 encodeUndo a (Undo obj) = "object" .= obj

+data ProofConfig u = ProofConfig
+    { proofKey     :: LocalRefURI
+    , proofCreated :: UTCTime
+    }
+
+instance ActivityPub ProofConfig where
+    jsonldContext _ = []
+    parseObject o = do
+        typ <- o .: "type"
+        guard $ typ == ("DataIntegrityProof" :: Text)
+        purpose <- o .: "proofPurpose"
+        guard $ purpose == ("assertionMethod" :: Text)
+        suite <- o .: "cryptosuite"
+        guard $ suite == ("jcs-eddsa-2022" :: Text)
+        RefURI h lruKey <- o .: "verificationMethod"
+        fmap (h,) $ ProofConfig
+            <$> pure lruKey
+            <*> o .: "created"
+    toSeries h (ProofConfig lruKey created)
+        =  "type"               .= ("DataIntegrityProof" :: Text)
+        <> "proofPurpose"       .= ("assertionMethod" :: Text)
+        <> "cryptosuite"        .= ("jcs-eddsa-2022" :: Text)
+        <> "verificationMethod" .= RefURI h lruKey
+        <> "created"            .= created
+
+data Proof u = Proof
+    { proofConfig :: ProofConfig u
+    , proofValue  :: ByteString
+    }
+
+instance ActivityPub Proof where
+    jsonldContext _ = []
+    parseObject o = do
+        (h, config) <- parseObject o
+        value <- do
+            t <- o .: "proofValue"
+            t58 <-
+                case T.uncons t of
+                    Just ('z', t') -> return t'
+                    _ -> fail $ "No multibase 'z' prefix: " ++ T.unpack t
+            let b = TE.encodeUtf8 t58
+            case B58.decodeBase58 B58.bitcoinAlphabet b of
+                Nothing ->
+                    fail $ "base58-btc decoding failed:" ++ T.unpack t
+                Just val -> return val
+        return (h, Proof config value)
+    toSeries h (Proof config sig)
+        =  toSeries h config
+        <> "proofValue" .=
+            T.cons 'z' (TE.decodeUtf8 $ B58.encodeBase58 B58.bitcoinAlphabet sig)
+
 data SpecificActivity u
    = AcceptActivity  (Accept u)
    | AddActivity     (Add u)
@ -1903,6 +1987,7 @@ makeActivity luId luActor Action{..} = Activity
    , activitySummary    = actionSummary
    , activityAudience   = actionAudience
    , activityFulfills   = actionFulfills
+    , activityProof      = Nothing
    , activitySpecific   = actionSpecific
    }

@ -1913,6 +1998,7 @@ data Activity u = Activity
    , activitySummary    :: Maybe HTML
    , activityAudience   :: Audience u
    , activityFulfills   :: [ObjURI u]
+    , activityProof      :: Maybe (Proof u)
    , activitySpecific   :: SpecificActivity u
    }

@ -1928,6 +2014,9 @@ instance ActivityPub Activity where
                <*> o .:? "summary"
                <*> parseAudience o
                <*> o .:? "fulfills" .!= []
+                <*> (do mp <- o .:? "proof"
+                        for mp $ withAuthorityT a . parseObject
+                    )
                <*> do
                    typ <- o .: "type"
                    case typ of
@ -1947,7 +2036,7 @@ instance ActivityPub Activity where
                        _ ->
                            fail $
                                "Unrecognized activity type: " ++ T.unpack typ
-    toSeries authority (Activity id_ actor mcap summary audience fulfills specific)
+    toSeries authority (Activity id_ actor mcap summary audience fulfills mproof specific)
        =  "type"       .=  activityType specific
        <> "id"         .=? (ObjURI authority <$> id_)
        <> "actor"      .=  ObjURI authority actor
@ -1955,6 +2044,7 @@ instance ActivityPub Activity where
        <> "summary"    .=? summary
        <> encodeAudience audience
        <> "fulfills"   .=% fulfills
+        <> "proof"      .=? (Doc authority <$> mproof)
        <> encodeSpecific authority actor specific
        where
        encodeSpecific h _ (AcceptActivity a)  = encodeAccept h a
@ -1982,6 +2072,7 @@ emptyActivity = Activity
    , activitySummary    = Nothing
    , activityAudience   = emptyAudience
    , activityFulfills   = []
+    , activityProof      = Nothing
    , activitySpecific   =
        RejectActivity $ Reject $ ObjURI (Authority "" Nothing) topLocalURI
    }
@ -2157,17 +2248,31 @@ sending
    :: UriMode u
    => LocalRefURI
    -> (ByteString -> S.Signature)
+    -> Maybe (ProofConfig u, ByteString -> ByteString)
    -> Bool
    -> ObjURI u
    -> LocalURI
    -> Action u
    -> Envelope u
-sending lruKey sign holder uActor@(ObjURI hActor luActor) luId action =
+sending lruKey sign mprove 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
+        , envelopeBody   =
+            let act = makeActivity luId luActor action
+                lb = encode $ Doc hActor act
+            in  case mprove of
+                    Nothing -> lb
+                    Just (config, prove) ->
+                        let configLB = encode $ Doc hActor config
+                            configHash = hashWith SHA256 $ BL.toStrict configLB
+                            bodyHash = hashWith SHA256 $ BL.toStrict lb
+                            input = BA.convert configHash `B.append` BA.convert bodyHash
+                            proof = Proof config (prove input)
+                            actWithProof = act { activityProof = Just proof }
+                        in  encode $ Doc hActor actWithProof
+
        }

 retrying
--- a/src/Web/Actor.hs
+++ b/src/Web/Actor.hs
@ -53,10 +53,12 @@ module Web.Actor
    )
 where

+import Control.Monad.IO.Class
 import Control.Monad.Trans.Except
 import Data.ByteString (ByteString)
 import Data.Proxy
 import Data.Text (Text)
+import Data.Time.Clock

 import qualified Data.ByteString.Lazy as BL

@ -176,10 +178,13 @@ prepareToSend
 prepareToSend keyR sign holder actorR idR action = do
    encodeRouteLocal <- getEncodeRouteLocal
    encodeRouteHome <- getEncodeRouteHome
+    now <- liftActor $ liftIO getCurrentTime
    let lruKey = LocalRefURI $ Left $ encodeRouteLocal keyR
        uActor = encodeRouteHome actorR
        luId = encodeRouteLocal idR
-    return $ AP.sending lruKey sign holder uActor luId action
+        config = AP.ProofConfig lruKey now
+        signB = S.unSignature . sign
+    return $ AP.sending lruKey sign (Just (config, signB)) holder uActor luId action

 prepareToForward
    :: (MonadActor m, ActorEnv m ~ s, StageWebRoute s, StageURIMode s ~ u)
--- a/src/Yesod/ActivityPub.hs
+++ b/src/Yesod/ActivityPub.hs
@ -104,7 +104,7 @@ prepareToSend keyR sign holder actorR idR action = do
    let lruKey = LocalRefURI $ Left $ encodeRouteLocal keyR
        uActor = encodeRouteHome actorR
        luId = encodeRouteLocal idR
-    return $ AP.sending lruKey sign holder uActor luId action
+    return $ AP.sending lruKey sign Nothing holder uActor luId action

 prepareToRetry
    :: (MonadSite m, SiteEnv m ~ site, SiteFedURI site, SiteFedURIMode site ~ u)
--- a/stack.yaml
+++ b/stack.yaml
@ -56,6 +56,7 @@ extra-deps:
  - url-2.1.3
  - annotated-exception-0.2.0.4
  - retry-0.9.3.1
+  - base58-bytestring-0.1.0

 # Override default flag values for local packages and extra-deps
 flags:
--- a/vervis.cabal
+++ b/vervis.cabal
@ -303,6 +303,7 @@ library
                     , base
                       -- for hex display of Darcs patch hashes
                     , base16-bytestring
+                     , base58-bytestring
                     , base64-bytestring
                       -- for Data.Binary.Local
                     , binary