Eventually-decentralized project hosting and management platform

[[ 🗃 ^WvWbo vervis ]] :: [📥 Inbox] [📤 Outbox] [🐤 Followers] [🤝 Collaborators] [🛠 Changes]

Clone

HTTPS: darcs clone https://vervis.peers.community/repos/WvWbo

SSH: darcs clone USERNAME@vervis.peers.community:WvWbo

Tags

TODO

src / Vervis / Data /

Follow.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.Follow
    ( FolloweeBy (..)
    , followeeActor
    , parseFollow
    )
where

import Control.Applicative
import Control.Monad
import Control.Monad.Trans.Except
import Data.Bitraversable
import Data.Foldable
import Data.Maybe
import Data.Text (Text)
import Database.Persist.Types

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

import qualified Web.ActivityPub as AP

import Control.Monad.Trans.Except.Local

import Vervis.Data.Actor
import Vervis.Data.Ticket
import Vervis.FedURI
import Vervis.Foundation
import Vervis.Model
import Vervis.Recipient

data FolloweeBy f
    = FolloweeActor (LocalActorBy f)
    | FolloweeWorkItem (WorkItemBy f)

followeeActor :: FolloweeBy f -> LocalActorBy f
followeeActor (FolloweeActor a) = a
followeeActor (FolloweeWorkItem wi) = workItemActor wi

unhashFolloweeE (FolloweeActor a) e = FolloweeActor <$> unhashLocalActorE a e
unhashFolloweeE (FolloweeWorkItem wi) e = FolloweeWorkItem <$> unhashWorkItemE wi e

parseFollow
    :: AP.Follow URIMode
    -> ExceptT Text Handler
        (Either (FolloweeBy Key) (Host, LocalURI, LocalURI), Bool)
parseFollow (AP.Follow uObject mluContext hide) = do
    routeOrRemote <- parseFedURIOld uObject
    (,hide) <$>
        bitraverse
            (parseLocal mluContext)
            (pure . makeRemote mluContext)
            routeOrRemote
    where
    parseFollowee r =
        FolloweeActor <$> parseLocalActor r <|>
        FolloweeWorkItem <$> parseWorkItem r
    parseLocal mlu r = do
        byHash <- fromMaybeE (parseFollowee r) "Not a followee route"
        byKey <- unhashFolloweeE byHash "Followee invalid keyhashid"
        for_ mlu $ \ lu -> nameExceptT "Follow context" $ do
            actorR <-parseLocalURI lu
            actorByKey <- parseLocalActorE actorR
            unless (actorByKey == followeeActor byKey) $
                throwE "Isn't object's actor"
        return byKey
    makeRemote mlu (ObjURI h lu) = (h, fromMaybe lu mlu, lu)
[See repo JSON]