vervis/src/Vervis/Data/Actor.hs

{- This file is part of Vervis.
 -
 - Written in 2022, 2023 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 Vervis.Data.Actor
    ( parseLocalActivityURI
    , parseLocalActivityURI'
    , parseActivityURI
    , parseActivityURI'
    , activityRoute
    , stampRoute
    , parseStampRoute
    , localActorID
    , parseLocalURI
    , parseFedURIOld
    , parseLocalActorE
    , parseLocalActorE'
    )
where

import Control.Concurrent.Chan
import Control.Concurrent.STM.TVar
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Logger.CallStack
import Control.Monad.Trans.Except
import Data.Text (Text)
import Database.Persist.Types
import UnliftIO.Exception (try, SomeException, displayException)

import qualified Data.HashMap.Strict as HM
import qualified Data.Text as T

import Network.FedURI
import Web.Actor
import Yesod.ActivityPub
import Yesod.Actor
import Yesod.FedURI
import Yesod.Hashids
import Yesod.MonadSite

import qualified Web.Actor as WA
import qualified Web.Actor.Persist as WAP

import Control.Monad.Trans.Except.Local

import Vervis.FedURI
import Vervis.Foundation
import Vervis.Model
import Vervis.Recipient

import qualified Vervis.Actor as VA

parseLocalActivityURI
    :: (MonadSite m, YesodHashids (SiteEnv m))
    => LocalURI
    -> ExceptT Text m (LocalActorBy Key, LocalActorBy KeyHashid, OutboxItemId)
parseLocalActivityURI luAct = do
    route <- fromMaybeE (decodeRouteLocal luAct) "Not a valid route"
    (actorHash, outboxItemHash) <-
        fromMaybeE
            (parseOutboxItemRoute route)
            "Valid local route, but not an outbox item route"
    outboxItemID <- decodeKeyHashidE outboxItemHash "Invalid outbox item hash"
    actorKey <- unhashLocalActorE actorHash "Invalid actor hash"
    return (actorKey, actorHash, outboxItemID)
    where
    parseOutboxItemRoute (PersonOutboxItemR p i) = Just (LocalActorPerson p, i)
    parseOutboxItemRoute (GroupOutboxItemR g i)  = Just (LocalActorGroup g, i)
    parseOutboxItemRoute (RepoOutboxItemR r i)   = Just (LocalActorRepo r, i)
    parseOutboxItemRoute (DeckOutboxItemR d i)   = Just (LocalActorDeck d, i)
    parseOutboxItemRoute (LoomOutboxItemR l i)   = Just (LocalActorLoom l, i)
    parseOutboxItemRoute (ProjectOutboxItemR r i)   = Just (LocalActorProject r, i)
    parseOutboxItemRoute _                       = Nothing

parseLocalActivityURI'
    :: LocalURI
    -> VA.ActE (LocalActorBy Key, LocalActorBy KeyHashid, OutboxItemId)
parseLocalActivityURI' luAct = do
    route <- fromMaybeE (WA.decodeRouteLocal luAct) "Not a valid route"
    (actorHash, outboxItemHash) <-
        fromMaybeE
            (parseOutboxItemRoute route)
            "Valid local route, but not an outbox item route"
    outboxItemID <- WAP.decodeKeyHashidE outboxItemHash "Invalid outbox item hash"
    actorKey <- VA.unhashLocalActorE actorHash "Invalid actor hash"
    return (actorKey, actorHash, outboxItemID)
    where
    parseOutboxItemRoute (PersonOutboxItemR p i) = Just (LocalActorPerson p, i)
    parseOutboxItemRoute (GroupOutboxItemR g i)  = Just (LocalActorGroup g, i)
    parseOutboxItemRoute (RepoOutboxItemR r i)   = Just (LocalActorRepo r, i)
    parseOutboxItemRoute (DeckOutboxItemR d i)   = Just (LocalActorDeck d, i)
    parseOutboxItemRoute (LoomOutboxItemR l i)   = Just (LocalActorLoom l, i)
    parseOutboxItemRoute (ProjectOutboxItemR r i)   = Just (LocalActorProject r, i)
    parseOutboxItemRoute _                       = Nothing

-- | If the given URI is remote, return as is. If the URI is local, verify that
-- it parses as an activity URI, i.e. an outbox item route, and return the
-- parsed route.
parseActivityURI
    :: (MonadSite m, SiteEnv m ~ App)
    => FedURI
    -> ExceptT Text m
        (Either
            (LocalActorBy Key, LocalActorBy KeyHashid, OutboxItemId)
            FedURI
        )
parseActivityURI u@(ObjURI h lu) = do
    hl <- hostIsLocalOld h
    if hl
        then Left <$> parseLocalActivityURI lu
        else pure $ Right u

-- | If the given URI is remote, return as is. If the URI is local, verify that
-- it parses as an activity URI, i.e. an outbox item route, and return the
-- parsed route.
parseActivityURI'
    :: FedURI
    -> VA.ActE
        (Either
            (LocalActorBy Key, LocalActorBy KeyHashid, OutboxItemId)
            FedURI
        )
parseActivityURI' u@(ObjURI h lu) = do
    hl <- WA.hostIsLocal h
    if hl
        then Left <$> parseLocalActivityURI' lu
        else pure $ Right u

activityRoute :: LocalActorBy KeyHashid -> KeyHashid OutboxItem -> Route App
activityRoute (LocalActorPerson p) = PersonOutboxItemR p
activityRoute (LocalActorGroup g) = GroupOutboxItemR g
activityRoute (LocalActorRepo r) = RepoOutboxItemR r
activityRoute (LocalActorDeck d) = DeckOutboxItemR d
activityRoute (LocalActorLoom l) = LoomOutboxItemR l
activityRoute (LocalActorProject r) = ProjectOutboxItemR r

stampRoute :: LocalActorBy KeyHashid -> KeyHashid SigKey -> Route App
stampRoute (LocalActorPerson p) = PersonStampR p
stampRoute (LocalActorGroup g) = GroupStampR g
stampRoute (LocalActorRepo r) = RepoStampR r
stampRoute (LocalActorDeck d) = DeckStampR d
stampRoute (LocalActorLoom l) = LoomStampR l
stampRoute (LocalActorProject r) = ProjectStampR r

parseStampRoute
    :: Route App -> Maybe (LocalActorBy KeyHashid, KeyHashid SigKey)
parseStampRoute (PersonStampR p i) = Just (LocalActorPerson p, i)
parseStampRoute (GroupStampR g i)  = Just (LocalActorGroup g, i)
parseStampRoute (RepoStampR r i)   = Just (LocalActorRepo r, i)
parseStampRoute (DeckStampR d i)   = Just (LocalActorDeck d, i)
parseStampRoute (LoomStampR l i)   = Just (LocalActorLoom l, i)
parseStampRoute (ProjectStampR r i)   = Just (LocalActorProject r, i)
parseStampRoute _                       = Nothing

localActorID :: LocalActorBy Entity -> ActorId
localActorID (LocalActorPerson (Entity _ p)) = personActor p
localActorID (LocalActorGroup (Entity _ g))  = groupActor g
localActorID (LocalActorRepo (Entity _ r))   = repoActor r
localActorID (LocalActorDeck (Entity _ d))   = deckActor d
localActorID (LocalActorLoom (Entity _ l))   = loomActor l
localActorID (LocalActorProject (Entity _ r))   = projectActor r

parseFedURIOld
    :: ( MonadSite m
       , SiteEnv m ~ site
       , YesodActivityPub site
       , SiteFedURIMode site ~ URIMode
       )
    => FedURI
    -> ExceptT Text m (Either (Route App) FedURI)
parseFedURIOld u@(ObjURI h lu) = do
    hl <- hostIsLocalOld h
    if hl
        then Left <$> parseLocalURI lu
        else pure $ Right u

parseLocalActorE :: Route App -> ExceptT Text Handler (LocalActorBy Key)
parseLocalActorE route = do
    actorByHash <- fromMaybeE (parseLocalActor route) "Not an actor route"
    unhashLocalActorE actorByHash "Invalid actor keyhashid"

parseLocalActorE' :: Route App -> VA.ActE (LocalActorBy Key)
parseLocalActorE' route = do
    actorByHash <- fromMaybeE (parseLocalActor route) "Not an actor route"
    VA.unhashLocalActorE actorByHash "Invalid actor keyhashid"