diff --git a/src/Crypto/ActorKey.hs b/src/Crypto/ActorKey.hs index 2ac7338..54eb83e 100644 --- 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 diff --git a/src/Vervis/API.hs b/src/Vervis/API.hs index 9f07aae..273fcaa 100644 --- 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 diff --git a/src/Vervis/Federation.hs b/src/Vervis/Federation.hs index 18a0f83..c47b260 100644 --- 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 diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index 0c74a50..1d3fe69 100644 --- 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 diff --git a/src/Vervis/Handler/Person.hs b/src/Vervis/Handler/Person.hs index b016ef3..bd88f53 100644 --- 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 diff --git a/src/Vervis/Migration.hs b/src/Vervis/Migration.hs index 8847dc8..156624c 100644 --- 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 . - - ♡ 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 diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index ee5a814..2a85b1b 100644 --- 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 diff --git a/src/Web/Actor.hs b/src/Web/Actor.hs index 72b4f24..ad020ed 100644 --- 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) diff --git a/src/Yesod/ActivityPub.hs b/src/Yesod/ActivityPub.hs index 1d58a83..5ec6179 100644 --- 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) diff --git a/stack.yaml b/stack.yaml index b326275..0445528 100644 --- 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: diff --git a/vervis.cabal b/vervis.cabal index 851e783..886d838 100644 --- 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