vervis/src/Yesod/ActivityPub.hs

{- 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 (..)
    , deliverActivity
    , forwardActivity
    )
where

import Prelude

import Data.ByteString (ByteString)
import Data.List.NonEmpty (NonEmpty)
import Data.Text (Text)
import Yesod.Core

import qualified Data.ByteString.Lazy as BL

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)
    {-
    siteSigVerRequiredHeaders :: site -> [HeaderName]
    siteSigVerWantedHeaders   :: site -> [HeaderName]
    siteSigVerSeconds         :: site -> Int
    -}

deliverActivity
    :: ( MonadSite m
       , SiteEnv m ~ site
       , HasHttpManager site
       , YesodActivityPub site
       )
    => FedURI
    -> Maybe FedURI
    -> Doc Activity
    -> m (Either APPostError (Response ()))
deliverActivity inbox mfwd 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 (Left <$> mfwd) doc

forwardActivity
    :: ( MonadSite m
       , SiteEnv m ~ site
       , HasHttpManager site
       , YesodActivityPub site
       )
    => FedURI
    -> ByteString
    -> Route site
    -> BL.ByteString
    -> m (Either APPostError (Response ()))
forwardActivity inbox sig rSender body = do
    manager <- asksSite getHttpManager
    headers <- asksSite sitePostSignedHeaders
    (keyid, sign) <- siteGetHttpSign
    renderUrl <- askUrlRender
    let sender = renderUrl rSender
    httpPostAPBytes manager inbox headers keyid sign sender (Just $ Right sig) body