mirror of
https://code.naskya.net/repos/ndqEd
synced 2025-03-20 15:14:54 +09:00
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.
This commit is contained in:
Pere Lev
parent
ba02d62eb5
commit
e8e587af26
11 changed files with 128 additions and 46 deletions
src/Web
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue