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
    , provideHtmlAndAP
    , provideHtmlAndAP'
    )
where

import Prelude

import Control.Exception
import Control.Monad.Logger.CallStack
import Data.ByteString (ByteString)
import Data.Foldable
import Data.List.NonEmpty (NonEmpty)
import Data.Text (Text)
import Network.HTTP.Client
import Network.HTTP.Types.Header
import Yesod.Core hiding (logError, logDebug)

import qualified Data.ByteString.Lazy as BL
import qualified Data.Text as T

import Network.HTTP.Signature

import Network.FedURI
import Web.ActivityPub
import Yesod.MonadSite
import Yesod.RenderSource

class Yesod site => YesodActivityPub site where
    siteInstanceHost          :: site -> Text
    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)
    result <-
        httpPostAP manager inbox headers keyid sign sender (Left <$> mfwd) doc
    case result of
        Left err ->
            logError $ T.concat
                [ "deliverActivity to inbox <", renderFedURI inbox
                , "> error: ", T.pack $ displayException err
                ]
        Right resp ->
            logDebug $ T.concat
                [ "deliverActivity to inbox <", renderFedURI inbox
                , "> success: ", T.pack $ show $ responseStatus resp
                ]
    return result

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
    result <-
        httpPostAPBytes manager inbox headers keyid sign sender (Just $ Right sig) body
    case result of
        Left err ->
            logError $ T.concat
                [ "forwardActivity to inbox <", renderFedURI inbox
                , "> error: ", T.pack $ displayException err
                ]
        Right resp ->
            logDebug $ T.concat
                [ "forwardActivity to inbox <", renderFedURI inbox
                , "> success: ", T.pack $ show $ responseStatus resp
                ]
    return result

provideHtmlAndAP
    :: (YesodActivityPub site, ActivityPub a)
    => a -> WidgetFor site () -> HandlerFor site TypedContent
provideHtmlAndAP object widget = do
    host <- getsYesod siteInstanceHost
    provideHtmlAndAP' host object widget

provideHtmlAndAP'
    :: (YesodActivityPub site, ActivityPub a)
    => Text -> a -> WidgetFor site () -> HandlerFor site TypedContent
provideHtmlAndAP' host object widget = selectRep $ do
    let doc = Doc host object
    provideAP $ pure doc
    provideRep $ do
        mval <- lookupGetParam "prettyjson"
        defaultLayout $
            case mval of
                Just "true" -> renderPrettyJSON doc
                _ -> do
                    widget
                    mroute <- getCurrentRoute
                    for_ mroute $ \ route -> do
                        params <- reqGetParams <$> getRequest
                        let pj = ("prettyjson", "true")
                        [whamlet|
                            <div>
                              <a href=@?{(route, pj : params)}>
                                [See JSON]
                        |]