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 }