{- 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/>.
 -}

{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

-- | Reusable library for building decentralized actor-model-based web apps,
-- with 'Control.Concurrent.Actor' for the local actor system, and ActivityPub
-- as the network protocol.
--
-- At the time of writing (April 2023), this module is collecting the pieces
-- that aren't tied to a specific web framework. Yesod-specific parts are in
-- separate modules.
--
-- Ideally, the whole application structure would be specified using
-- framework-independent tools, and framework integration (right now just
-- Yesod, might also be Servant in the future) would be an automatic or
-- auto-generated nearly-seamless part. I hope to get there, gradually, in
-- steps of refactoring.
module Web.Actor
    ( StageWeb (..)
    , DecodeRouteLocal (..)
    , StageWebRoute (..)
    , askUrlRender
    , ActForE
    , hostIsLocal
    , parseLocalURI
    , parseFedURI

      -- Adapted from Yesod.FedURI
    , getEncodeRouteLocal
    , getEncodeRouteHome
    , getEncodeRouteFed
    , getEncodeRoutePageLocal
    , getEncodeRoutePageHome
    , getEncodeRoutePageFed

      -- Adapted from Yesod.ActivityPub
    , prepareToSend
    , prepareToForward
    )
where

import Control.Monad.IO.Class
import Control.Monad.Trans.Except
import Data.ByteString (ByteString)
import Data.Proxy
import Data.Text (Text)
import Data.Time.Clock

import qualified Data.ByteString.Lazy as BL

import qualified Network.HTTP.Signature as S

import Control.Concurrent.Actor
import Network.FedURI
import Web.Actor.Deliver

import qualified Web.ActivityPub as AP

import Control.Monad.Trans.Except.Local

type ActForE s = ExceptT Text (ActFor s)

class (Stage s, UriMode (StageURIMode s)) => StageWeb s where
    type StageURIMode s
    stageInstanceHost :: StageEnv s -> Authority (StageURIMode s)
    stageDeliveryTheater :: StageEnv s -> DeliveryTheater (StageURIMode s)

class DecodeRouteLocal r where
    decodeRouteLocal :: LocalURI -> Maybe r

class (DecodeRouteLocal (StageRoute s), StageWeb s) => StageWebRoute s where
    type StageRoute s
    askUrlRenderParams
        :: (MonadActor m, MonadActorStage m ~ s)
        => m (StageRoute s -> [(Text, Text)] -> Text)
    -- | Name of parameter to use in generated URIs' query part to indicate the
    -- page number in a paginated collection
    pageParamName :: Proxy s -> Text

askUrlRender
    :: (MonadActor m, MonadActorStage m ~ s, StageWebRoute s)
    => m (StageRoute s -> Text)
askUrlRender = do
    render <- askUrlRenderParams
    return $ \ route -> render route []

hostIsLocal
    :: (MonadActor m, MonadActorStage m ~ s, StageWeb s)
    => Authority (StageURIMode s) -> m Bool
hostIsLocal h = asksEnv $ (== h) . stageInstanceHost

parseLocalURI :: (Monad m, DecodeRouteLocal r) => LocalURI -> ExceptT Text m r
parseLocalURI lu = fromMaybeE (decodeRouteLocal lu) "Not a valid route"

parseFedURI
    :: StageWebRoute s
    => ObjURI (StageURIMode s)
    -> ActForE s (Either (StageRoute s) (ObjURI (StageURIMode s)))
parseFedURI u@(ObjURI h lu) = do
    hl <- hostIsLocal h
    if hl
        then Left <$> parseLocalURI lu
        else pure $ Right u

getEncodeRouteHome
    :: (MonadActor m, MonadActorStage m ~ s, StageWebRoute s)
    => m (StageRoute s -> ObjURI (StageURIMode s))
getEncodeRouteHome = toFed <$> askUrlRender
    where
    toFed renderUrl route =
        case parseObjURI $ renderUrl route of
            Left e -> error $ "askUrlRender produced invalid ObjURI: " ++ e
            Right u -> u

getEncodeRouteLocal
    :: (MonadActor m, MonadActorStage m ~ s, StageWebRoute s)
    => m (StageRoute s -> LocalURI)
getEncodeRouteLocal = (objUriLocal .) <$> getEncodeRouteHome

getEncodeRouteFed
    :: ( MonadActor m
       , MonadActorStage m ~ s
       , StageWebRoute s
       , StageURIMode s ~ u
       )
    => m (Authority u -> StageRoute s -> ObjURI u)
getEncodeRouteFed = (\ f a -> ObjURI a . f) <$> getEncodeRouteLocal

getEncodeRoutePageLocal
    :: (MonadActor m, MonadActorStage m ~ s, StageWebRoute s)
    => m (StageRoute s -> Int -> LocalPageURI)
getEncodeRoutePageLocal =
    (\ f r n -> pageUriLocal $ f r n) <$> getEncodeRoutePageHome

getEncodeRoutePageHome
    :: forall m s. (MonadActor m, MonadActorStage m ~ s, StageWebRoute s)
    => m (StageRoute s -> Int -> PageURI (StageURIMode s))
getEncodeRoutePageHome = do
    encodeRouteHome <- getEncodeRouteHome
    let param = pageParamName (Proxy @s)
    return $ \ route page ->
        let ObjURI a l = encodeRouteHome route
        in  PageURI a $ LocalPageURI l param page

getEncodeRoutePageFed
    :: ( MonadActor m
       , MonadActorStage m ~ s
       , StageWebRoute s
       , StageURIMode s ~ u
       )
    => m (Authority u -> StageRoute s -> Int -> PageURI u)
getEncodeRoutePageFed =
    (\ f a r n -> PageURI a $ f r n) <$> getEncodeRoutePageLocal

prepareToSend
    :: (MonadActor m, MonadActorStage m ~ s, StageWebRoute s, StageURIMode s ~ u)
    => StageRoute s
    -> (ByteString -> S.Signature)
    -> Bool
    -> StageRoute s
    -> StageRoute s
    -> AP.Action u
    -> m (AP.Envelope u)
prepareToSend keyR sign holder actorR idR action = do
    encodeRouteLocal <- getEncodeRouteLocal
    encodeRouteHome <- getEncodeRouteHome
    now <- liftActor $ liftIO getCurrentTime
    let lruKey = LocalRefURI $ Left $ encodeRouteLocal keyR
        uActor = encodeRouteHome actorR
        luId = encodeRouteLocal idR
        config = AP.ProofConfig lruKey now
        signB = S.unSignature . sign
    return $ AP.sending lruKey sign (Just (config, signB)) holder uActor luId action

prepareToForward
    :: (MonadActor m, MonadActorStage m ~ s, StageWebRoute s, StageURIMode s ~ u)
    => StageRoute s
    -> (ByteString -> S.Signature)
    -> Bool
    -> StageRoute s
    -> BL.ByteString
    -> Maybe ByteString
    -> m (AP.Errand u)
prepareToForward keyR sign holder fwderR body msig = do
    encodeRouteLocal <- getEncodeRouteLocal
    encodeRouteHome <- getEncodeRouteHome
    let lruKey = LocalRefURI $ Left $ encodeRouteLocal keyR
        uFwder = encodeRouteHome fwderR
    return $ AP.forwarding lruKey sign holder uFwder body msig