{- This file is part of Vervis.
 -
 - Written in 2019, 2022, 2023, 2024 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 (..)

    --, prepareToSend
    , prepareToRetry
    , deliverActivity
    , deliverActivityExcept
    , deliverActivityThrow

    --, prepareToForward
    , forwardActivity
    , forwardActivityExcept
    , forwardActivityThrow

    , redirectToPrettyJSON

    , provideHtmlAndAP
    , provideHtmlAndAP'
    , provideHtmlAndAP''
    , provideHtmlFeedAndAP

    , provideHtmlAndAP_F3
    , provideHtmlAndAP_F3'

    , hostIsLocalOld
    , verifyHostLocal
    )
where

import Control.Exception.Base
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Logger.CallStack
import Control.Monad.Trans.Except
import Control.Monad.Trans.Writer
import Data.Aeson
import Data.Aeson.Encode.Pretty
import Data.ByteString (ByteString)
import Data.Foldable
import Data.Function
import Data.List
import Data.List.NonEmpty (NonEmpty)
import Data.Semigroup
import Data.Text (Text)
import Network.HTTP.Client
import Network.HTTP.Types.Header
import Yesod.AtomFeed
import Yesod.Core hiding (logError, logDebug)
import Yesod.Feed
import Yesod.RssFeed

import qualified Data.ByteString.Lazy as BL
import qualified Data.HashMap.Strict as M
import qualified Data.Text as T

import Network.HTTP.Signature

import qualified Network.HTTP.Signature as S

import Database.Persist.JSON
import Network.FedURI
import Web.ActivityPub
import Yesod.FedURI
import Yesod.MonadSite
import Yesod.RenderSource

import qualified Web.ActivityPub as AP

class (Yesod site, SiteFedURI site) => YesodActivityPub site where
    siteInstanceHost          :: site -> Authority (SiteFedURIMode site)
    sitePostSignedHeaders     :: site -> NonEmpty HeaderName
    {-
    siteGetHttpSign           :: (MonadSite m, SiteEnv m ~ site)
                              => m (KeyId, ByteString -> Signature)
    siteSigVerRequiredHeaders :: site -> [HeaderName]
    siteSigVerWantedHeaders   :: site -> [HeaderName]
    siteSigVerSeconds         :: site -> Int
    -}

prepareToSend
    :: (MonadSite m, SiteEnv m ~ site, SiteFedURI site, SiteFedURIMode site ~ u)
    => Route site
    -> (ByteString -> S.Signature)
    -> Bool
    -> Route site
    -> Route site
    -> AP.Action u
    -> m (Envelope u)
prepareToSend keyR sign holder actorR idR action = do
    encodeRouteLocal <- getEncodeRouteLocal
    encodeRouteHome <- getEncodeRouteHome
    let lruKey = LocalRefURI $ Left $ encodeRouteLocal keyR
        uActor = encodeRouteHome actorR
        luId = encodeRouteLocal idR
    return $ AP.sending lruKey sign Nothing holder uActor luId action

prepareToRetry
    :: (MonadSite m, SiteEnv m ~ site, SiteFedURI site, SiteFedURIMode site ~ u)
    => Route site
    -> (ByteString -> S.Signature)
    -> Maybe (Route site)
    -> BL.ByteString
    -> m (Envelope u)
prepareToRetry keyR sign mHolderR body = do
    encodeRouteLocal <- getEncodeRouteLocal
    encodeRouteHome <- getEncodeRouteHome
    let ruKey =
            let ObjURI h lu = encodeRouteHome keyR
            in  RefURI h $ LocalRefURI $ Left lu
        mluHolder = encodeRouteLocal <$> mHolderR
    return $ AP.retrying ruKey sign mluHolder body

deliverActivity
    :: ( MonadSite m, SiteEnv m ~ site, SiteFedURIMode site ~ u
       , YesodActivityPub site
       , HasHttpManager site
       )
    => Envelope u
    -> Maybe LocalURI
    -> ObjURI u
    -> m (Either APPostError (Response ()))
deliverActivity envelope mluFwd uInbox = do
    manager <- asksSite getHttpManager
    headers <- asksSite sitePostSignedHeaders
    AP.deliver manager headers envelope mluFwd uInbox

deliverActivityExcept
    :: ( MonadSite m, SiteEnv m ~ site, SiteFedURIMode site ~ u
       , YesodActivityPub site
       , HasHttpManager site
       )
    => Envelope u
    -> Maybe LocalURI
    -> ObjURI u
    -> ExceptT APPostError m (Response ())
deliverActivityExcept envelope mluFwd uInbox =
    ExceptT $ deliverActivity envelope mluFwd uInbox

deliverActivityThrow
    :: ( MonadSite m, SiteEnv m ~ site, SiteFedURIMode site ~ u
       , YesodActivityPub site
       , HasHttpManager site
       )
    => Envelope u
    -> Maybe LocalURI
    -> ObjURI u
    -> m (Response ())
deliverActivityThrow envelope mluFwd uInbox = do
    result <- deliverActivity envelope mluFwd uInbox
    case result of
        Left e -> liftIO $ throwIO e
        Right response -> return response

{-
prepareToForward
    :: (MonadSite m, SiteEnv m ~ site, SiteFedURI site, SiteFedURIMode site ~ u)
    => Route site
    -> (ByteString -> S.Signature)
    -> Bool
    -> Route site
    -> BL.ByteString
    -> ByteString
    -> m (Errand u)
prepareToForward keyR sign holder fwderR body sig = do
    encodeRouteLocal <- getEncodeRouteLocal
    encodeRouteHome <- getEncodeRouteHome
    let lruKey = LocalRefURI $ Left $ encodeRouteLocal keyR
        uFwder = encodeRouteHome fwderR
    return $ AP.forwarding lruKey sign holder uFwder body sig
-}

forwardActivity
    :: ( MonadSite m, SiteEnv m ~ site
       , SiteFedURI site, SiteFedURIMode site ~ u
       , HasHttpManager site
       , YesodActivityPub site
       )
    => Errand u
    -> ObjURI u
    -> m (Either APPostError (Response ()))
forwardActivity errand uInbox = do
    manager <- asksSite getHttpManager
    headers <- asksSite sitePostSignedHeaders
    AP.forward manager headers errand uInbox

forwardActivityExcept
    :: ( MonadSite m, SiteEnv m ~ site
       , SiteFedURI site, SiteFedURIMode site ~ u
       , HasHttpManager site
       , YesodActivityPub site
       )
    => Errand u
    -> ObjURI u
    -> ExceptT APPostError m (Response ())
forwardActivityExcept errand uInbox = ExceptT $ forwardActivity errand uInbox

forwardActivityThrow
    :: ( MonadSite m, SiteEnv m ~ site
       , SiteFedURI site, SiteFedURIMode site ~ u
       , HasHttpManager site
       , YesodActivityPub site
       )
    => Errand u
    -> ObjURI u
    -> m (Response ())
forwardActivityThrow errand uInbox = do
    result <- forwardActivity errand uInbox
    case result of
        Left e -> liftIO $ throwIO e
        Right response -> return response

{-
-- | An 'AP.Activity' ready for sending, attached to an actor key ready to sign
-- it
data Envelope u = Envelope
    { envelopeKey    :: LocalRefURI
    , envelopeSign   :: ByteString -> S.Signature
    , envelopeHolder :: Bool
    , envelopeActor  :: ObjURI u
    , envelopeId     :: LocalURI
    , envelopeAction :: Action u
    }
-}

{-
-- | An 'AP.Activity' ready for sending, attached to an actor key ready to sign
-- it
data Envelope site = Envelope
    { -- | Signing key's identifier URI
      envelopeKey       :: Route site
      -- | Signing function, producing a signature for a given input
    , envelopeSign      :: ByteString -> Signature
      -- | Whether the signing key is used for the whole instance, or a
      -- personal key used only by one actor
    , envelopeSharedKey :: Bool
      -- | The actor signing and sending the activity
    , envelopeActor     :: Route site
      -- | Activity's ID URI
    , envelopeId        :: Route site
      -- | Activity document, just needing its actor and id to be filled in
    , envelopeAction    :: AP.Action (SiteFedURIMode site)
    }
-}

{-
prepareActivity
    :: Route site
    -> (ByteString -> S.Signature)
    -> Bool
    -> Route site
    -> Route site
    -> AP.Action u
    -> m (Envelope u)
prepareActivity keyR sign holder actorR idR action = do
    encodeRouteLocal <- getEncodeRouteLocal
    encodeRouteHome <- getEncodeRouteHome
    let lruKey = LocalRefURI $ Left $ encodeRouteLocal keyR
        uActor = encodeRouteHome actorR
        luId = encodeRouteLocal idR
    return $ Envelope lruKey sign holder uActor luId action

    return $ AP.send manager headers lruKey sign holder uActor luId action

sendActivity
    :: Envelope u
    -> Maybe LocalURI
    -> ObjURI u
    -> m (Either AP.APPostError (Response ()))
sendActivity (Envelope lruKey sign holder uActor luId action)
-}

{-
prepareSendActivity
    :: ( MonadSite m
       , SiteEnv m ~ site
       , SiteFedURIMode site ~ u
       , HasHttpManager site
       , YesodActivityPub site
       )
    => Route site
    -> (ByteString -> S.Signature)
    -> Bool
    -> Route site
    -> Route site
    -> AP.Action u
    -> m (Maybe LocalURI -> ObjURI u -> m (Either AP.APPostError (Response ())))
prepareSendActivity keyR sign holder actorR idR action = do
    manager <- asksSite getHttpManager
    headers <- asksSite sitePostSignedHeaders
    encodeRouteLocal <- getEncodeRouteLocal
    encodeRouteHome <- getEncodeRouteHome
    let lruKey = LocalRefURI $ Left $ encodeRouteLocal keyR
        uActor = encodeRouteHome actorR
        luId = encodeRouteLocal idR
    return $ AP.send manager headers lruKey sign holder uActor luId action

resendActivity
    :: ( MonadSite m
       , SiteEnv m ~ site
       , SiteFedURIMode site ~ u
       , HasHttpManager site
       , YesodActivityPub site
       )
    => Route site
    -> (ByteString -> S.Signature)
    -> Maybe (Route site)
    -> BL.ByteString
    -> Maybe LocalURI
    -> ObjURI u
    -> m (Either AP.APPostError (Response ()))
resendActivity keyR sign mHolderR body mluFwd uInbox = do
    manager <- asksSite getHttpManager
    headers <- asksSite sitePostSignedHeaders
    encodeRouteLocal <- getEncodeRouteLocal
    encodeRouteHome <- getEncodeRouteHome
    let ruKey =
            let ObjURI h lu = encodeRouteHome keyR
            in  RefURI h $ LocalRefURI $ Left lu
        mluHolder = encodeRouteLocal <$> mHolderR
    AP.resend manager headers ruKey sign mluHolder body mluFwd uInbox

forwardActivity
    :: ( MonadSite m
       , SiteEnv m ~ site
       , SiteFedURIMode site ~ u
       , HasHttpManager site
       , YesodActivityPub site
       )
    -> Route site
    -> (ByteString -> S.Signature)
    -> Bool
    -> Route site
    -> BL.ByteString
    -> ByteString
    -> ObjURI u
    -> m (Either APPostError (Response ()))
forwardActivity keyR sign holder fwderR body sig uInbox = do
    manager <- asksSite getHttpManager
    headers <- asksSite sitePostSignedHeaders
    encodeRouteLocal <- getEncodeRouteLocal
    encodeRouteHome <- getEncodeRouteHome
    let lruKey = LocalRefURI $ Left $ encodeRouteLocal keyR
        uFwder = encodeRouteHome fwderR
    AP.forward lruKey sign holder uFwder body sig uInbox
-}

{-
data Stamp site = Stamp
    { stampActor :: Route site
    , stampKey   :: Route site
    , stampSign  :: ByteString -> Signature
    }

-- | An 'AP.Activity' ready for sending, attached to an actor key ready to sign
-- it
data Envelope site = Envelope
    { -- | Activity document, just needing its actor and id to be filled in
      envelopeDoc   :: AP.Action (SiteFedURIMode site)
      -- | Activity's ID URI
    , envelopeId    :: Route site
      -- | The actor signing and sending the activity
    , envelopeActor :: Route site
      -- | Signing key's identifier URI
    , envelopeKey   :: Route site
      -- | Signing function, producing a signature for a given input
    , envelopeSign  :: ByteString -> Signature
    }

deliverActivityBL
    :: ( MonadSite m
       , SiteEnv m ~ site
       , SiteFedURIMode site ~ u
       , HasHttpManager site
       , YesodActivityPub site
       )
    => ObjURI u
    -> Maybe (ObjURI u)
    -> Stamp
    -> BL.ByteString
    -> m (Either APPostError (Response ()))
deliverActivityBL inbox mfwd (Stamp actorR keyR sign) body = do
    manager <- asksSite getHttpManager
    headers <- asksSite sitePostSignedHeaders
    (sender, keyid) <- do
        renderUrl <- askUrlRender
        return (renderUrl actorR, KeyId $ renderUrl keyR)
    result <-
        httpPostAPBytes
            manager inbox headers keyid sign sender (Left <$> mfwd) body
    case result of
        Left err ->
            logError $ T.concat
                [ "deliverActivity to inbox <", renderObjURI inbox
                , "> error: ", T.pack $ displayException err
                ]
        Right resp ->
            logDebug $ T.concat
                [ "deliverActivity to inbox <", renderObjURI inbox
                , "> success: ", T.pack $ show $ responseStatus resp
                ]
    return result

deliverActivity
    :: ( MonadSite m
       , SiteEnv m ~ site
       , SiteFedURIMode site ~ u
       , HasHttpManager site
       , YesodActivityPub site
       )
    => ObjURI u
    -> Maybe (ObjURI u)
    -> Envelope site
    -> m (Either APPostError (Response ()))
deliverActivity inbox mfwd (Envelope action idR actorR keyR sign) = do
    encodeRouteLocal <- getEncodeRouteLocal
    hLocal <- asksSite siteInstanceHost
    let body =
            encode $ Doc hLocal $
                makeActivity
                    (encodeRouteLocal idR) (encodeRouteLocal actorR) action
    deliverActivityBL inbox mfwd (Stamp actorR keyR sign) body

data Errand site = Errand
    { errandDoc   :: BL.ByteString
    , errandProof :: ByteString
    , errandActor :: Route site
    , errandKey   :: Route site
    , errandSign  :: ByteString -> Signature
    }

forwardActivity
    :: ( MonadSite m
       , SiteEnv m ~ site
       , SiteFedURIMode site ~ u
       , HasHttpManager site
       , YesodActivityPub site
       )
    => ObjURI u
    -> Errand site
    -> m (Either APPostError (Response ()))
forwardActivity inbox (Errand doc sig actorR keyR sign) = do
    encodeRouteLocal <- getEncodeRouteLocal
    encodeRouteHome <- getEncodeRouteHome
    manager <- asksSite getHttpManager
    headers <- asksSite sitePostSignedHeaders
    let uActor = encodeRouteHome actorR
        lruKey = LocalRefURI $ Left $ encodeRouteLocal keyR
    result <- AP.forward manager headers uActor lruKey sign doc inbox sig
    case result of
        Left err ->
            logError $ T.concat
                [ "forwardActivity to inbox <", renderObjURI inbox
                , "> error: ", T.pack $ displayException err
                ]
        Right resp ->
            logDebug $ T.concat
                [ "forwardActivity to inbox <", renderObjURI inbox
                , "> success: ", T.pack $ show $ responseStatus resp
                ]
    return result
-}

redirectToPrettyJSON
    :: (MonadHandler m, HandlerSite m ~ site) => Route site -> m a
redirectToPrettyJSON route = redirect (route, [("prettyjson", "true")])

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

provideHtmlAndAP_F3
    :: ( YesodActivityPub site
       , SiteFedURIMode site ~ u
       , ActivityPub a
       , ToJSON f3
       )
    => a u
    -> WidgetFor site ()
    -> f3
    -> HandlerFor site TypedContent
provideHtmlAndAP_F3 object widget f3 = do
    host <- getsYesod siteInstanceHost
    provideHtmlAndAP_F3' host object widget f3

typeF3 :: ContentType
typeF3 = "application/f3+json"

provideF3 :: (Monad m, ToJSON a) => m a -> Writer (Endo [ProvidedRep m]) ()
provideF3 mk = provideRepType typeF3 $ toEncoding <$> mk

provideHtmlAndAP_
    :: (Yesod site, ToJSON f3)
    => (a -> Writer (Endo [ProvidedRep (HandlerFor site)]) ())
    -> (a -> WidgetFor site ())
    -> (a -> WidgetFor site ())
    -> a
    -> WidgetFor site ()
    -> Maybe (Feed (Route site))
    -> Maybe f3
    -> HandlerFor site TypedContent
provideHtmlAndAP_ provide renderSky renderHl doc widget mfeed mf3 = selectRep $ do
    provide doc
    provideRep $ do
        mval <- lookupGetParam "prettyjson"
        defaultLayout $
            case mval of
                Just "true" -> do
                    mhl <- lookupGetParam "highlight"
                    let sky = case mhl of
                                Nothing -> True
                                Just "hl2" -> False
                                Just "sky" -> True
                                Just _ -> error "Invalid highlight style"
                    if sky
                        then renderSky doc
                        else renderHl doc
                    mroute <- getCurrentRoute
                    for_ mroute $ \ route -> do
                        params <- reqGetParams <$> getRequest
                        let params' =
                                delete' "prettyjson" $
                                    delete' "highlight" params
                        [whamlet|
                            <div>
                              <a href=@?{(route, params')}>
                                [See HTML]
                        |]
                _ -> do
                    widget
                    mroute <- getCurrentRoute
                    for_ mroute $ \ route -> do
                        params <- reqGetParams <$> getRequest
                        let pj = ("prettyjson", "true")
                            hl = ("highlight", "sky")
                            params' = pj : hl : params
                        [whamlet|
                            <div>
                              <a href=@?{(route, params')}>
                                [See JSON]
                        |]
    for_ mfeed $ \ feed -> do
        provideRep $ atomFeed feed
        provideRep $ rssFeed feed
    for_ mf3 $ provideF3 . pure
    where
    delete' t = deleteBy ((==) `on` fst) (t, "")

noF3 :: Maybe ()
noF3 = Nothing

provideHtmlAndAP'
    :: ( YesodActivityPub site
       , SiteFedURIMode site ~ u
       , ActivityPub a
       )
    => Authority u
    -> a u
    -> WidgetFor site ()
    -> HandlerFor site TypedContent
provideHtmlAndAP' host object widget =
    provideHtmlAndAP_
        (provideAP . pure)
        renderPrettyJSONSkylighting
        renderPrettyJSON
        (Doc host object)
        widget
        Nothing
        noF3

provideHtmlAndAP_F3'
    :: ( YesodActivityPub site
       , SiteFedURIMode site ~ u
       , ActivityPub a
       , ToJSON f3
       )
    => Authority u
    -> a u
    -> WidgetFor site ()
    -> f3
    -> HandlerFor site TypedContent
provideHtmlAndAP_F3' host object widget f3 =
    provideHtmlAndAP_
        (provideAP . pure)
        renderPrettyJSONSkylighting
        renderPrettyJSON
        (Doc host object)
        widget
        Nothing
        (Just f3)

provideHtmlAndAP''
    :: Yesod site
    => PersistJSON a -> WidgetFor site () -> HandlerFor site TypedContent
provideHtmlAndAP'' body widget =
    provideHtmlAndAP_
        (provideAP' . pure . persistJSONBytes)
        (renderPrettyJSONSkylighting' . encodePretty . persistJSONObject)
        (renderPrettyJSON' . encodePretty . persistJSONObject)
        body
        widget
        Nothing
        noF3

provideHtmlFeedAndAP
    :: (YesodActivityPub site, SiteFedURIMode site ~ u, ActivityPub a)
    => a u
    -> Feed (Route site)
    -> WidgetFor site ()
    -> HandlerFor site TypedContent
provideHtmlFeedAndAP object feed widget = do
    host <- getsYesod siteInstanceHost
    provideHtmlAndAP_
        (provideAP . pure)
        renderPrettyJSONSkylighting
        renderPrettyJSON
        (Doc host object)
        widget
        (Just feed)
        noF3

hostIsLocalOld
    :: (MonadSite m, SiteEnv m ~ site, YesodActivityPub site)
    => Authority (SiteFedURIMode site) -> m Bool
hostIsLocalOld h = asksSite $ (== h) . siteInstanceHost

verifyHostLocal
    :: (MonadSite m, SiteEnv m ~ site, YesodActivityPub site)
    => Authority (SiteFedURIMode site) -> Text -> ExceptT Text m ()
verifyHostLocal h t = do
    local <- hostIsLocalOld h
    unless local $ throwE t