New module Yesod.ActivityPub, use it in Vervis.Federation for delivery POSTing

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

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

src/Yesod/ActivityPub.hs

@@ -0,0 +1,57 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2019 by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ 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
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+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

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