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 / Persist /

Follow.hs

{- This file is part of Vervis.
 -
 - Written in 2022 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.Persist.Follow
    ( getFollowee
    , getFollowee'
    , tryUnfollow
    )
where

import Control.Applicative
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Logger.CallStack
import Control.Monad.Trans.Class
import Control.Monad.Trans.Except
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Reader
import Data.Barbie
import Data.Bitraversable
import Data.Functor
import Data.Maybe
import Data.Text (Text)
import Data.Traversable
import Database.Persist
import Database.Persist.Sql

import qualified Data.Text as T
import qualified Database.Esqueleto as E

import Crypto.ActorKey
import Database.Persist.JSON
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 Data.Either.Local
import Database.Persist.Local

import Vervis.Cloth
import Vervis.Data.Actor
import Vervis.Data.Follow
import Vervis.Data.Ticket
import Vervis.FedURI
import Vervis.Foundation
import Vervis.Model
import Vervis.Persist.Actor
import Vervis.Persist.Ticket
import Vervis.Recipient
import Vervis.Settings
import Vervis.Ticket

getFollowee
    :: MonadIO m
    => FolloweeBy Key
    -> ExceptT Text (ReaderT SqlBackend m)
        (LocalActorBy Key, ActorId, Maybe FollowerSetId)
getFollowee (FolloweeActor actorByKey) = do
    actorByEntity <- do
        maybeActor <- lift $ getLocalActorEntity actorByKey
        fromMaybeE maybeActor "Actor not found in DB"
    return (actorByKey, localActorID actorByEntity, Nothing)
getFollowee (FolloweeWorkItem wi) =
    case wi of
        WorkItemTicket deckID taskID -> do
            actorID <- deckActor <$> getE deckID "No such deck in DB"
            (_, _, Entity _ ticket, _, _) <- do
                mticket <- lift $ getTicket deckID taskID
                fromMaybeE mticket "No such ticket in DB"
            return
                ( LocalActorDeck deckID
                , actorID
                , Just $ ticketFollowers ticket
                )
        WorkItemCloth loomID clothID -> do
            actorID <- loomActor <$> getE loomID "No such loom in DB"
            (_, _, Entity _ ticket, _, _, _) <- do
                mcloth <- lift $ getCloth loomID clothID
                fromMaybeE mcloth "No such MR in DB"
            return
                ( LocalActorLoom loomID
                , actorID
                , Just $ ticketFollowers ticket
                )

getFollowee' followerSetID = do
    actorOrTicket <-
        requireEitherAlt
            (getKeyBy $ UniqueActorFollowers followerSetID)
            (getKeyBy $ UniqueTicketFollowers followerSetID)
            "Can't find who's using this FollowerSet"
            "Multi use of FollowerSet"
    either FolloweeActor FolloweeWorkItem <$>
        bitraverse getLocalActor getWorkItem actorOrTicket

tryUnfollow (Left (_actorByKey, _actorEntity, itemID)) =
    runMaybeT $
        MaybeT forRemoteRequest <|> MaybeT forRemote <|> MaybeT forLocal
    where
    forRemoteRequest = do
        maybeFollow <- getBy $ UniqueFollowRemoteRequestActivity itemID
        for maybeFollow $ \ (Entity requestID request) -> do
            actorID <-
                personActor <$> getJust (followRemoteRequestPerson request)
            let uTarget =
                    fromMaybe (followRemoteRequestTarget request) $
                        followRemoteRequestRecip request
            return (delete requestID, actorID, Right uTarget)
    forRemote = do
        maybeFollow <- getBy $ UniqueFollowRemoteFollow itemID
        for maybeFollow $ \ (Entity remoteID remote) -> do
            let actorID = followRemoteActor remote
            uTarget <- getRemoteActorURI =<< getJust (followRemoteRecip remote)
            return (delete remoteID, actorID, Right uTarget)
    forLocal = do
        maybeFollow <- getBy $ UniqueFollowFollow itemID
        return $ maybeFollow <&> \ (Entity followID follow) ->
            let actorID = followActor follow
                followerSetID = followTarget follow
            in  (delete followID, actorID, Left followerSetID)
tryUnfollow (Right _) = pure Nothing
[See repo JSON]