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

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

config/routes

@@ -26,6 +26,8 @@
 
 /inbox                                       InboxR            GET POST
 /outbox                                      OutboxR           GET POST
+/akey1                                       ActorKey1R        GET
+/akey2                                       ActorKey2R        GET
 
 -- ----------------------------------------------------------------------------
 -- Current user

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

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 =

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

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

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

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
                         }