From e325175a9ca440e7c85d66ddbe27ae9d06ec7ce7 Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Thu, 7 Feb 2019 10:34:33 +0000 Subject: [PATCH] Publish 2 rotating instance-scope keys instead of the one-implicitly-shared-key Before, there was a single key used as a personal key for all actors. Now, things work like this: - There are 2 keys, each time one is rotated, this way the old key remains valid and we can freely rotate without a risk of race conditions on other servers and end up with our posts being rejected - The keys are explicitly instance-scope keys, all actors refer to them - We add the ActivityPub-Actor header to all activity POSTs we send, to declare for which specific actor our signature applies. Activities and otherwise different payloads may have varying ways to specify attribution; using this header will be a standard uniform way to specify the actor, regardless of payload format. Of course, servers should make sure the actual activity is attributed to the same actor we specified in the header. (This is important with instance-scope keys; for personal keys it's not critical) --- config/models | 14 +++++------ config/routes | 2 ++ src/Vervis/ActorKey.hs | 18 +++++++++----- src/Vervis/Application.hs | 6 +++-- src/Vervis/Foundation.hs | 2 +- src/Vervis/Handler/Inbox.hs | 48 +++++++++++++++++++++++++++++++----- src/Vervis/Handler/Person.hs | 14 ++--------- src/Web/ActivityPub.hs | 12 ++++++--- 8 files changed, 78 insertions(+), 38 deletions(-) diff --git a/config/models b/config/models index a6a9365..08f4ade 100644 --- a/config/models +++ b/config/models @@ -80,13 +80,6 @@ GroupMember UniqueGroupMember person group -RepoCollab - repo RepoId - person PersonId - role ProjectRoleId Maybe - - UniqueRepoCollab repo person - ProjectRole ident RlIdent sharer SharerId @@ -106,6 +99,13 @@ ProjectAccess UniqueProjectAccess role op +RepoCollab + repo RepoId + person PersonId + role ProjectRoleId Maybe + + UniqueRepoCollab repo person + ProjectCollab project ProjectId person PersonId diff --git a/config/routes b/config/routes index 153ed7a..802b184 100644 --- a/config/routes +++ b/config/routes @@ -26,6 +26,8 @@ /inbox InboxR GET POST /outbox OutboxR GET POST +/akey1 ActorKey1R GET +/akey2 ActorKey2R GET -- ---------------------------------------------------------------------------- -- Current user diff --git a/src/Vervis/ActorKey.hs b/src/Vervis/ActorKey.hs index c1ed729..aca85f8 100644 --- a/src/Vervis/ActorKey.hs +++ b/src/Vervis/ActorKey.hs @@ -27,7 +27,7 @@ where import Prelude import Control.Concurrent (threadDelay) -import Control.Concurrent.STM (TVar, writeTVar) +import Control.Concurrent.STM (TVar, modifyTVar') import Control.Monad (forever) import Control.Monad.STM (atomically) import Crypto.Error (throwCryptoErrorIO) @@ -140,17 +140,23 @@ generateActorKey = mk <$> generateSecretKey -- renderPEM :: PublicKey -> ByteString -- renderPEM = pemWriteBS . PEM "PUBLIC KEY" [] . convert --- | A loop that runs forever and periodically generates a new actor key, --- storing it in a 'TVar'. -actorKeyRotator :: TimeInterval -> TVar ActorKey -> IO () -actorKeyRotator interval key = +-- | 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 +-- which key gets rotated. +actorKeyRotator :: TimeInterval -> TVar (ActorKey, ActorKey, Bool) -> IO () +actorKeyRotator interval keys = let micros = microseconds interval in if 0 < micros && micros <= toInteger (maxBound :: Int) then let micros' = fromInteger micros in forever $ do threadDelay micros' - generateActorKey >>= atomically . writeTVar key + fresh <- generateActorKey + atomically $ + modifyTVar' keys $ \ (k1, k2, new1) -> + if new1 + then (k1 , fresh, False) + else (fresh, k2 , True) else error $ "actorKeyRotator: interval out of range: " ++ show micros diff --git a/src/Vervis/Application.hs b/src/Vervis/Application.hs index 17f7927..a33bd45 100644 --- a/src/Vervis/Application.hs +++ b/src/Vervis/Application.hs @@ -111,7 +111,9 @@ makeFoundation appSettings = do then lin2 else loadFont "data/LinLibertineCut.svg" - appActorKey <- newTVarIO =<< generateActorKey + appActorKeys <- + newTVarIO =<< + (,,) <$> generateActorKey <*> generateActorKey <*> pure True appCapSignKey <- loadActorKey $ appCapabilitySigningKeyFile appSettings @@ -204,7 +206,7 @@ develMain = develMainHelper getApplicationDev actorKeyPeriodicRotator :: App -> IO () actorKeyPeriodicRotator app = - actorKeyRotator (appActorKeyRotation $ appSettings app) (appActorKey app) + actorKeyRotator (appActorKeyRotation $ appSettings app) (appActorKeys app) sshServer :: App -> IO () sshServer foundation = diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index 17f84c9..257b2e8 100644 --- a/src/Vervis/Foundation.hs +++ b/src/Vervis/Foundation.hs @@ -83,7 +83,7 @@ data App = App , appLogger :: Logger , appMailQueue :: Maybe (Chan (MailRecipe App)) , appSvgFont :: PreparedFont Double - , appActorKey :: TVar ActorKey + , appActorKeys :: TVar (ActorKey, ActorKey, Bool) , appCapSignKey :: ActorKey , appActivities :: TVar (Vector (UTCTime, Either String (ByteString, BL.ByteString))) diff --git a/src/Vervis/Handler/Inbox.hs b/src/Vervis/Handler/Inbox.hs index 5908756..056efef 100644 --- a/src/Vervis/Handler/Inbox.hs +++ b/src/Vervis/Handler/Inbox.hs @@ -18,6 +18,8 @@ module Vervis.Handler.Inbox , postInboxR , getOutboxR , postOutboxR + , getActorKey1R + , getActorKey2R ) where @@ -36,7 +38,7 @@ import Data.Aeson.Encode.Pretty.ToEncoding import Data.Bifunctor (first, second) import Data.HashMap.Strict (HashMap) import Data.List.NonEmpty (NonEmpty (..)) -import Data.PEM (pemContent) +import Data.PEM (PEM (..)) import Data.Text (Text) import Data.Text.Encoding (encodeUtf8) import Data.Text.Lazy.Encoding (decodeUtf8) @@ -52,6 +54,7 @@ import Text.Blaze.Html (Html) import UnliftIO.Exception (try) import Yesod.Auth (requireAuth) import Yesod.Core (ContentType, defaultLayout, whamlet, toHtml) +import Yesod.Core.Content (TypedContent) import Yesod.Core.Json (requireJsonBody) import Yesod.Core.Handler import Yesod.Form.Fields (Textarea (..), textareaField) @@ -72,9 +75,11 @@ import Yesod.HttpSignature (verifyRequestSignature) import qualified Network.HTTP.Signature as S (Algorithm (..)) +import Data.Aeson.Local (parseHttpsURI') + import Web.ActivityPub -import Vervis.ActorKey (actorKeySign) +import Vervis.ActorKey import Vervis.Foundation import Vervis.Model import Vervis.Settings (AppSettings (appHttpSigTimeLimit)) @@ -264,7 +269,8 @@ postOutboxR = do let actorID = renderUrl $ PersonR shr actID = actorID <> "/fake/1" objID = actorID <> "/fake/2" - keyID = actorID <> "#key" + keyID1 = renderUrl ActorKey1R + keyID2 = renderUrl ActorKey2R updateObj (Object obj) = Object $ M.insert "attributedTo" (String actorID) $ M.insert "id" (String objID) obj updateObj v = v updateAct = M.adjust updateObj "object" . M.insert "actor" (String actorID) . M.insert "id" (String actID) @@ -279,10 +285,40 @@ postOutboxR = do if actorId actor /= to then setMessage "Fetched actor JSON but its id doesn't match the URL we fetched" else do - akey <- liftIO . readTVarIO =<< getsYesod appActorKey - let sign b = (KeyId $ encodeUtf8 keyID, actorKeySign akey b) - eres' <- httpPostAP manager (actorInbox actor) (hRequestTarget :| [hHost, hDate]) sign (updateAct act) + (akey1, akey2, new1) <- liftIO . readTVarIO =<< getsYesod appActorKeys + let (keyID, akey) = + if new1 + then (keyID1, akey1) + else (keyID2, akey2) + sign b = (KeyId $ encodeUtf8 keyID, actorKeySign akey b) + eres' <- httpPostAP manager (actorInbox actor) (hRequestTarget :| [hHost, hDate, hActivityPubActor]) sign actorID (updateAct act) case eres of Left e -> setMessage $ toHtml $ "Failed to POST to recipient's inbox: " <> T.pack (displayException e) Right _ -> setMessage "Activity posted! You can go to the target server's /inbox to see the result." defaultLayout $ activityWidget widget enctype + +getActorKey :: ((ActorKey, ActorKey, Bool) -> ActorKey) -> Route App -> Handler TypedContent +getActorKey choose route = do + actorKey <- + liftIO . fmap (actorKeyPublicBin . choose) . readTVarIO =<< + getsYesod appActorKeys + renderUrl <- getUrlRender + let route2uri r = + case parseHttpsURI' $ renderUrl r of + Left e -> error e + Right u -> u + selectRep $ + provideAP PublicKey + { publicKeyId = route2uri route + , publicKeyExpires = Nothing + , publicKeyOwner = route2uri HomeR + , publicKeyPem = PEM "PUBLIC KEY" [] actorKey + , publicKeyAlgo = Just AlgorithmEd25519 + , publicKeyShared = True + } + +getActorKey1R :: Handler TypedContent +getActorKey1R = getActorKey (\ (k1, _, _) -> k1) ActorKey1R + +getActorKey2R :: Handler TypedContent +getActorKey2R = getActorKey (\ (k1, _, _) -> k1) ActorKey2R diff --git a/src/Vervis/Handler/Person.hs b/src/Vervis/Handler/Person.hs index f364132..a255828 100644 --- a/src/Vervis/Handler/Person.hs +++ b/src/Vervis/Handler/Person.hs @@ -27,7 +27,6 @@ where import Vervis.Import hiding ((==.)) --import Prelude -import Data.PEM (PEM (..)) import Database.Esqueleto hiding (isNothing, count) import Network.URI (uriFragment, parseAbsoluteURI) import Vervis.Form.Person @@ -142,8 +141,6 @@ getPersonR shr = do Nothing -> error "getRenderUrl produced invalid URI!!!" Just u -> u me = route2uri $ PersonR shr - actorKey <- - liftIO . fmap actorKeyPublicBin . readTVarIO =<< getsYesod appActorKey selectRep $ do provideRep $ do secure <- getSecure @@ -154,15 +151,8 @@ getPersonR shr = do , actorUsername = shr2text shr , actorInbox = route2uri InboxR , actorPublicKeys = PublicKeySet - { publicKey1 = Right PublicKey - { publicKeyId = me { uriFragment = "#key" } - , publicKeyExpires = Nothing - , publicKeyOwner = me - , publicKeyPem = PEM "PUBLIC KEY" [] actorKey - , publicKeyAlgo = Just AlgorithmEd25519 - , publicKeyShared = False - } - , publicKey2 = Nothing + { publicKey1 = Left $ route2uri ActorKey1R + , publicKey2 = Just $ Left $ route2uri ActorKey2R } } diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index f7ba391..92d2a6d 100644 --- a/src/Web/ActivityPub.hs +++ b/src/Web/ActivityPub.hs @@ -32,6 +32,7 @@ module Web.ActivityPub , Activity (..) -- * Utilities + , hActivityPubActor , provideAP , APGetError (..) , httpGetAP @@ -282,6 +283,9 @@ typeActivityStreams2LD :: ContentType typeActivityStreams2LD = "application/ld+json; profile=\"https://www.w3.org/ns/activitystreams\"" +hActivityPubActor :: HeaderName +hActivityPubActor = "ActivityPub-Actor" + provideAP :: (Monad m, ToJSON a) => a -> Writer (Endo [ProvidedRep m]) () provideAP v = do let enc = toEncoding v @@ -325,13 +329,11 @@ httpGetAP manager uri = else Left $ APGetErrorContentType $ "Non-AP Content-Type: " <> decodeUtf8 b _ -> Left $ APGetErrorContentType "Multiple Content-Type" --- Set method to POST, Set Content-Type, make HTTP signature, set response to throw on non-2xx --- status - -- | Perform an HTTP POST request to submit an ActivityPub object. -- -- * Verify the URI scheme is _https:_ and authority part is present -- * Set _Content-Type_ request header +-- * Set _ActivityPub-Actor_ request header -- * Compute HTTP signature and add _Signature_ request header -- * Perform the POST request -- * Verify the response status is 2xx @@ -341,9 +343,10 @@ httpPostAP -> URI -> NonEmpty HeaderName -> (ByteString -> (KeyId, Signature)) + -> Text -> a -> m (Either HttpException (Response ())) -httpPostAP manager uri headers sign value = +httpPostAP manager uri headers sign uActor value = if uriScheme uri /= "https:" then return $ Left $ InvalidUrlException (show uri) "Scheme isn't https" else liftIO $ try $ do @@ -351,6 +354,7 @@ httpPostAP manager uri headers sign value = let req' = setRequestCheckStatus $ consHeader hContentType typeActivityStreams2LD $ + consHeader hActivityPubActor (encodeUtf8 uActor) $ req { method = "POST" , requestBody = RequestBodyLBS $ encode value }