diff --git a/src/Vervis/Federation.hs b/src/Vervis/Federation.hs index 6243712..ae1413c 100644 --- a/src/Vervis/Federation.hs +++ b/src/Vervis/Federation.hs @@ -69,6 +69,7 @@ import Network.HTTP.Signature import Database.Persist.JSON import Network.FedURI import Web.ActivityPub hiding (Follow) +import Yesod.ActivityPub import Yesod.Auth.Unverified import Yesod.FedURI import Yesod.Hashids @@ -495,31 +496,14 @@ newtype FedError = FedError Text deriving Show instance Exception FedError -getHttpSign - :: (MonadSite m, SiteEnv m ~ App) => m (KeyId, ByteString -> Signature) -getHttpSign = do - (akey1, akey2, new1) <- liftIO . readTVarIO =<< asksSite appActorKeys - renderUrl <- askUrlRender - let (keyID, akey) = - if new1 - then (renderUrl ActorKey1R, akey1) - else (renderUrl ActorKey2R, akey2) - return (KeyId $ encodeUtf8 keyID, actorKeySign akey) - deliverHttp :: (MonadSite m, SiteEnv m ~ App) - => (KeyId, ByteString -> Signature) - -> Doc Activity + => Doc Activity -> Text -> LocalURI -> m (Either APPostError (Response ())) -deliverHttp (keyid, sign) doc h luInbox = do - manager <- asksSite appHttpManager - let inbox = l2f h luInbox - headers = hRequestTarget :| [hHost, hDate, hActivityPubActor] - httpPostAP manager inbox headers keyid sign docActor Nothing doc - where - docActor = renderFedURI $ l2f (docHost doc) (activityActor $ docValue doc) +deliverHttp doc h luInbox = + postActivity (l2f h luInbox) Nothing doc isInstanceErrorHttp (InvalidUrlException _ _) = False isInstanceErrorHttp (HttpExceptionRequest _ hec) = @@ -1077,8 +1061,7 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished c ) -> Handler () deliverRemoteHttp obid doc (fetched, unfetched, unknown) = do - sign <- getHttpSign - let deliver = deliverHttp sign doc + let deliver = deliverHttp doc now <- liftIO getCurrentTime traverse_ (fork . deliverFetched deliver now) fetched traverse_ (fork . deliverUnfetched deliver now) unfetched @@ -1221,8 +1204,7 @@ retryOutboxDelivery = do let (linkedOld, linkedNew) = partitionEithers $ map (decideBySinceDL dropAfter now . adaptLinked) linked deleteWhere [DeliveryId <-. linkedOld] return (groupUnlinked lonelyNew, groupLinked linkedNew) - sign <- getHttpSign - let deliver = deliverHttp sign + let deliver = deliverHttp waitsDL <- traverse (fork . deliverLinked deliver now) dls waitsUDL <- traverse (fork . deliverUnlinked deliver now) udls resultsDL <- sequence waitsDL diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index 7c1bfe8..20a5131 100644 --- a/src/Vervis/Foundation.hs +++ b/src/Vervis/Foundation.hs @@ -28,6 +28,7 @@ import Crypto.Hash.Algorithms import Data.Char import Data.Either (isRight) import Data.HashMap.Strict (HashMap) +import Data.List.NonEmpty (NonEmpty (..)) import Data.Maybe (fromJust) import Data.PEM (pemContent) import Data.Text.Encoding (decodeUtf8') @@ -73,6 +74,7 @@ import Crypto.PublicVerifKey import Network.FedURI import Web.ActivityAccess import Web.ActivityPub +import Yesod.ActivityPub import Yesod.Hashids import Yesod.MonadSite @@ -80,7 +82,7 @@ import Text.Email.Local import Text.Jasmine.Local (discardm) import Vervis.Access -import Vervis.ActorKey (ActorKey) +import Vervis.ActorKey import Vervis.Import.NoFoundation hiding (Handler, Day, last, init, logWarn) import Vervis.Model.Group import Vervis.Model.Ident @@ -643,6 +645,18 @@ instance YesodRemoteActorStore App where siteRejectOnMaxKeys = appRejectOnMaxKeys . appSettings siteActorFetchShare = appActorFetchShare +instance YesodActivityPub App where + sitePostSignedHeaders _ = + hRequestTarget :| [hHost, hDate, hActivityPubActor] + siteGetHttpSign = do + (akey1, akey2, new1) <- liftIO . readTVarIO =<< asksSite appActorKeys + renderUrl <- askUrlRender + let (keyID, akey) = + if new1 + then (renderUrl ActorKey1R, akey1) + else (renderUrl ActorKey2R, akey2) + return (KeyId $ encodeUtf8 keyID, actorKeySign akey) + data ActorDetail = ActorDetail { actorDetailId :: FedURI , actorDetailInstance :: InstanceId diff --git a/src/Yesod/ActivityPub.hs b/src/Yesod/ActivityPub.hs new file mode 100644 index 0000000..68ab564 --- /dev/null +++ b/src/Yesod/ActivityPub.hs @@ -0,0 +1,57 @@ +{- This file is part of Vervis. + - + - Written in 2019 by fr33domlover . + - + - ♡ Copying is an act of love. Please copy, reuse and share. + - + - The author(s) have dedicated all copyright and related and neighboring + - rights to this software to the public domain worldwide. This software is + - distributed without any warranty. + - + - You should have received a copy of the CC0 Public Domain Dedication along + - with this software. If not, see + - . + -} + +module Yesod.ActivityPub + ( YesodActivityPub (..) + , postActivity + ) +where + +import Prelude + +import Data.ByteString (ByteString) +import Data.List.NonEmpty (NonEmpty) +import Data.Text (Text) +import Yesod.Core + +import Network.HTTP.Client +import Network.HTTP.Signature +import Network.HTTP.Types.Header + +import Network.FedURI +import Web.ActivityPub +import Yesod.MonadSite + +class Yesod site => YesodActivityPub site where + sitePostSignedHeaders :: site -> NonEmpty HeaderName + siteGetHttpSign :: (MonadSite m, SiteEnv m ~ site) + => m (KeyId, ByteString -> Signature) + +postActivity + :: ( MonadSite m + , SiteEnv m ~ site + , HasHttpManager site + , YesodActivityPub site + ) + => FedURI + -> Maybe (Either FedURI (KeyId, ByteString)) + -> Doc Activity + -> m (Either APPostError (Response ())) +postActivity inbox mrecip doc@(Doc hAct activity) = do + manager <- asksSite getHttpManager + headers <- asksSite sitePostSignedHeaders + (keyid, sign) <- siteGetHttpSign + let sender = renderFedURI $ l2f hAct (activityActor activity) + httpPostAP manager inbox headers keyid sign sender mrecip doc diff --git a/vervis.cabal b/vervis.cabal index 1e473cc..c84a5fd 100644 --- a/vervis.cabal +++ b/vervis.cabal @@ -96,6 +96,7 @@ library Web.ActivityPub Web.Hashids.Local Web.PathPieces.Local + Yesod.ActivityPub Yesod.Auth.Unverified Yesod.Auth.Unverified.Creds Yesod.Auth.Unverified.Internal