diff --git a/config/models b/config/models index c601890..2b4c450 100644 --- a/config/models +++ b/config/models @@ -51,6 +51,7 @@ VerifKey RemoteSharer ident FedURI instance InstanceId + inbox FedURI UniqueRemoteSharer ident diff --git a/migrations/2019_02_03_verifkey.model b/migrations/2019_02_03_verifkey.model index 113b886..4070d79 100644 --- a/migrations/2019_02_03_verifkey.model +++ b/migrations/2019_02_03_verifkey.model @@ -10,6 +10,7 @@ VerifKey RemoteSharer ident Text instance InstanceId + inbox Text UniqueRemoteSharer ident diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index c075e97..06d56f3 100644 --- a/src/Vervis/Foundation.hs +++ b/src/Vervis/Foundation.hs @@ -22,6 +22,7 @@ import Control.Monad.Trans.Except import Control.Monad.Trans.Maybe import Crypto.Error (CryptoFailable (..)) import Crypto.PubKey.Ed25519 (publicKey, signature, verify) +import Data.Either (isRight) import Data.Maybe (fromJust) import Data.PEM (pemContent) import Data.Text.Encoding (decodeUtf8') @@ -593,7 +594,7 @@ instance YesodHttpSig App where t <- first displayException $ decodeUtf8' b parseFedURI t _ -> throwE "Multiple ActivityPub-Actor headers" - (mvkid, key, mexpires, uActor, host, shared) <- do + (inboxOrVkid, key, mexpires, uActor, host, shared) <- do ments <- lift $ runDB $ do mvk <- getBy $ UniqueVerifKey u for mvk $ \ vk@(Entity _ verifkey) -> do @@ -610,7 +611,7 @@ instance YesodHttpSig App where Just u -> return (u, True) let uKey = verifKeyIdent vk return - ( Just vkid + ( Right vkid , verifKeyPublic vk , verifKeyExpires vk , ua @@ -618,12 +619,12 @@ instance YesodHttpSig App where , s ) Nothing -> do - Fetched k mexp ua h s <- fetchKey' muActorHeader u - return (Nothing, k, mexp, ua, h, s) + Fetched k mexp ua uinb h s <- fetchKey' muActorHeader u + return (Left uinb, k, mexp, ua, h, s) let verify' k = verify k input signature errSig = throwE "Ed25519 sig verification says not valid" errTime = throwE "Key expired" - existsInDB = isJust mvkid + existsInDB = isRight inboxOrVkid now <- liftIO getCurrentTime let stillValid Nothing = True stillValid (Just expires) = expires > now @@ -632,7 +633,7 @@ instance YesodHttpSig App where then return (not existsInDB, key, mexpires) else if existsInDB then do - Fetched newKey newExp newActor h s <- fetchKey' muActorHeader u + Fetched newKey newExp newActor _newInbox h s <- fetchKey' muActorHeader u if shared == s then return () else throwE "Key scope changed, we reject that" @@ -653,8 +654,8 @@ instance YesodHttpSig App where then errSig else errTime when write $ ExceptT $ runDB $ - case mvkid of - Nothing -> + case inboxOrVkid of + Left inbox -> if shared then do ment <- getBy $ UniqueInstance host @@ -674,12 +675,8 @@ instance YesodHttpSig App where ment <- getBy $ UniqueRemoteSharer uActor case ment of Nothing -> do - iid <- do - ment2 <- getBy $ UniqueInstance host - case ment2 of - Nothing -> insert $ Instance host - Just (Entity i _) -> return i - rsid <- insert $ RemoteSharer uActor iid + iid <- either entityKey id <$> insertBy (Instance host) + rsid <- insert $ RemoteSharer uActor iid inbox insert_ $ VerifKey u iid mexpires' key' (Just rsid) return $ Right () Just (Entity rsid rs) -> do @@ -690,7 +687,7 @@ instance YesodHttpSig App where insert_ $ VerifKey u iid mexpires' key' (Just rsid) return $ Right () else return $ Left "We already store 2 keys" - Just vkid -> do + Right vkid -> do update vkid [VerifKeyExpires =. mexpires', VerifKeyPublic =. key'] return $ Right () diff --git a/src/Vervis/Handler/Inbox.hs b/src/Vervis/Handler/Inbox.hs index c7b8a03..b507154 100644 --- a/src/Vervis/Handler/Inbox.hs +++ b/src/Vervis/Handler/Inbox.hs @@ -35,6 +35,7 @@ import Crypto.Error (CryptoFailable (..)) import Crypto.PubKey.Ed25519 (publicKey, signature, verify) import Data.Aeson import Data.Bifunctor (first, second) +import Data.Foldable (for_) import Data.HashMap.Strict (HashMap) import Data.List.NonEmpty (NonEmpty (..)) import Data.PEM (PEM (..)) @@ -44,7 +45,7 @@ import Data.Text.Lazy.Encoding (decodeUtf8) import Data.Time.Clock (UTCTime, getCurrentTime) import Data.Time.Interval (TimeInterval, toTimeUnit) import Data.Time.Units (Second) -import Database.Persist (Entity (..)) +import Database.Persist (Entity (..), getBy, insertBy, insert_) import Network.HTTP.Client (Manager, HttpException, requestFromURI) import Network.HTTP.Simple (httpJSONEither, getResponseBody, setRequestManager, addRequestHeader) import Network.HTTP.Types.Header (hDate, hHost) @@ -229,27 +230,47 @@ postOutboxR = do } } manager <- getsYesod appHttpManager - eres <- httpGetAP manager to - case eres of - Left (APGetErrorHTTP e) -> setMessage $ toHtml $ "Failed to GET the recipient actor: " <> T.pack (displayException e) - Left (APGetErrorJSON e) -> setMessage $ toHtml $ "Failed to parse recipient actor JSON: " <> T.pack (displayException e) - Left (APGetErrorContentType e) -> setMessage $ toHtml $ "Got unexpected Content-Type for actor JSON: " <> e - Right response -> do - let actor = getResponseBody response - if actorId actor /= to - then setMessage "Fetched actor JSON but its id doesn't match the URL we fetched" - else do - (akey1, akey2, new1) <- liftIO . readTVarIO =<< getsYesod appActorKeys - let (keyID, akey) = - if new1 - then (renderUrl ActorKey1R, akey1) - else (renderUrl ActorKey2R, akey2) - sign b = (KeyId $ encodeUtf8 keyID, actorKeySign akey b) - eres' <- httpPostAP manager (actorInbox actor) (hRequestTarget :| [hHost, hDate, hActivityPubActor]) sign actorID activity - 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." + minbox <- fetchInboxURI manager to + for_ minbox $ \ inbox -> do + (akey1, akey2, new1) <- liftIO . readTVarIO =<< getsYesod appActorKeys + let (keyID, akey) = + if new1 + then (renderUrl ActorKey1R, akey1) + else (renderUrl ActorKey2R, akey2) + sign b = (KeyId $ encodeUtf8 keyID, actorKeySign akey b) + eres' <- httpPostAP manager inbox (hRequestTarget :| [hHost, hDate, hActivityPubActor]) sign actorID activity + 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 + where + fetchInboxURI :: Manager -> FedURI -> Handler (Maybe FedURI) + fetchInboxURI manager to = do + mrs <- runDB $ getBy $ UniqueRemoteSharer to + case mrs of + Nothing -> do + eres <- httpGetAP manager to + case eres of + Left (APGetErrorHTTP e) -> do + setMessage $ toHtml $ "Failed to GET the recipient actor: " <> T.pack (displayException e) + return Nothing + Left (APGetErrorJSON e) -> do + setMessage $ toHtml $ "Failed to parse recipient actor JSON: " <> T.pack (displayException e) + return Nothing + Left (APGetErrorContentType e) -> do + setMessage $ toHtml $ "Got unexpected Content-Type for actor JSON: " <> e + return Nothing + Right response -> do + let actor = getResponseBody response + if actorId actor /= to + then setMessage "Fetched actor JSON but its id doesn't match the URL we fetched" >> return Nothing + else do + let inbox = actorInbox actor + runDB $ do + iid <- either entityKey id <$> insertBy (Instance $ furiHost to) + insert_ $ RemoteSharer to iid inbox + return $ Just inbox + Just (Entity _rsid rs) -> return $ Just $ remoteSharerInbox rs getActorKey :: ((ActorKey, ActorKey, Bool) -> ActorKey) -> Route App -> Handler TypedContent getActorKey choose route = do diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index 59ba0b5..edde43b 100644 --- a/src/Web/ActivityPub.hs +++ b/src/Web/ActivityPub.hs @@ -390,6 +390,8 @@ data Fetched = Fetched -- ^ Optional expiration time declared for the key we received. , fetchedActorId :: FedURI -- ^ The @id URI of the actor for whom the key's signature applies. + , fetchedActorInbox :: FedURI + -- ^ The inbox URI of the actor for whom the key's signature applies. , fetchedHost :: Text -- ^ The domain name of the instance from which we got the key. , fetchedKeyShared :: Bool @@ -484,6 +486,7 @@ fetchKey manager sigAlgo muActor uKey = runExceptT $ do { fetchedPublicKey = k , fetchedKeyExpires = publicKeyExpires pkey , fetchedActorId = actorId actor + , fetchedActorInbox = actorInbox actor , fetchedHost = furiHost uKey , fetchedKeyShared = shared }