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.

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

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

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

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

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

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

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

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)

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)

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:

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