forge/Vervis
1
0
Fork 0
Code Pull requests Activity

Generate FEP-8b32 authenticity proofs when delivering activities

Browse source 
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.
This commit is contained in:
Pere Lev 2023-05-30 09:48:21 +03:00
parent ba02d62eb5
commit e8e587af26
No known key found for this signature in database
GPG key ID: 5252C5C863E5E57D
11 changed files with 128 additions and 46 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
src/Crypto/ActorKey.hs
View file

@ -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

6
src/Vervis/API.hs
View file

@ -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

37
src/Vervis/Federation.hs
View file

@ -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

2
src/Vervis/Foundation.hs
View file

@ -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

2
src/Vervis/Handler/Person.hs
View file

@ -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

3
src/Vervis/Migration.hs
View file

@ -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

111
src/Web/ActivityPub.hs
View file

@ -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

7
src/Web/Actor.hs
View file

@ -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)

2
src/Yesod/ActivityPub.hs
View file

@ -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)

1
stack.yaml
View file

@ -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:

1
vervis.cabal
View file

@ -303,6 +303,7 @@ library
, base
-- for hex display of Darcs patch hashes
, base16-bytestring
, base58-bytestring
, base64-bytestring
-- for Data.Binary.Local
, binary