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 /

Federation.hs

{- This file is part of Vervis.
 -
 - Written in 2019, 2020, 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.Federation
    (
    )
where

import Control.Applicative
import Control.Concurrent.MVar
import Control.Concurrent.STM.TVar
import Control.Exception hiding (Handler, try)
import Control.Monad
import Control.Monad.Logger.CallStack
import Control.Monad.Trans.Except
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Reader
import Crypto.Hash
import Data.Aeson
import Data.Barbie
import Data.Bifunctor
import Data.ByteString (ByteString)
import Data.Either
import Data.Foldable
import Data.Function
import Data.List (sort, deleteBy, nub, union, unionBy, partition)
import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
import Data.Maybe
import Data.Semigroup
import Data.Text (Text)
import Data.Text.Encoding
import Data.Time.Clock
import Data.Time.Units
import Data.Traversable
import Data.Tuple
import Database.Persist hiding (deleteBy)
import Database.Persist.Sql hiding (deleteBy)
import GHC.Generics
import Network.HTTP.Client
import Network.HTTP.Types.Header
import Network.HTTP.Types.URI
import Network.TLS hiding (SHA256)
import UnliftIO.Exception (try)
import Yesod.Core hiding (logError, logWarn, logInfo, logDebug)
import Yesod.Persist.Core

import qualified Data.ByteString.Lazy as BL
import qualified Data.CaseInsensitive as CI
import qualified Data.List as L
import qualified Data.List.NonEmpty as NE
import qualified Data.List.Ordered as LO
import qualified Data.Text as T
import qualified Database.Esqueleto as E
import qualified Network.Wai as W

import Data.Time.Interval
import Network.HTTP.Signature hiding (requestHeaders)
import Yesod.HttpSignature

import Crypto.PublicVerifKey
import Database.Persist.JSON
import Network.FedURI
import Network.HTTP.Digest
import Web.ActivityPub hiding (Follow, Ticket)
import Yesod.ActivityPub
import Yesod.Auth.Unverified
import Yesod.FedURI
import Yesod.Hashids
import Yesod.MonadSite

import qualified Web.ActivityPub as AP

import Control.Monad.Trans.Except.Local
import Data.Aeson.Local
import Data.Either.Local
import Data.List.Local
import Data.List.NonEmpty.Local
import Data.Maybe.Local
import Data.Tuple.Local
import Database.Persist.Local
import Yesod.Persist.Local

import Vervis.ActivityPub
import Vervis.ActorKey
import Vervis.Web.Delivery
import Vervis.Federation.Auth
import Vervis.Foundation
import Vervis.Model
import Vervis.Recipient
import Vervis.RemoteActorStore
import Vervis.Settings

{-

handleProjectInbox
    :: ShrIdent
    -> PrjIdent
    -> UTCTime
    -> ActivityAuthentication
    -> ActivityBody
    -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
handleProjectInbox shrRecip prjRecip now auth body = do
    remoteAuthor <-
        case auth of
            ActivityAuthLocal local -> throwE $ errorLocalForwarded local
            ActivityAuthRemote ra -> return ra
    luActivity <-
        fromMaybeE (activityId $ actbActivity body) "Activity without 'id'"
    localRecips <- do
        mrecips <- parseAudience $ activityAudience $ actbActivity body
        paudLocalRecips <$> fromMaybeE mrecips "Activity with no recipients"
    msig <- checkForwarding $ LocalActorProject shrRecip prjRecip
    let mfwd = (localRecips,) <$> msig
    case activitySpecific $ actbActivity body of
        CreateActivity (Create obj mtarget) ->
            case obj of
                CreateNote _ note ->
                    (,Nothing) <$> projectCreateNoteF now shrRecip prjRecip remoteAuthor body mfwd luActivity note
                CreateTicket _ ticket ->
                    (,Nothing) <$> projectCreateTicketF now shrRecip prjRecip remoteAuthor body mfwd luActivity ticket mtarget
                _ -> error "Unsupported create object type for projects"
        FollowActivity follow ->
            (,Nothing) <$> projectFollowF shrRecip prjRecip now remoteAuthor body mfwd luActivity follow
        OfferActivity (Offer obj target) ->
            case obj of
                OfferTicket ticket ->
                    (,Nothing) <$> projectOfferTicketF now shrRecip prjRecip remoteAuthor body mfwd luActivity ticket target
                OfferDep dep ->
                    projectOfferDepF now shrRecip prjRecip remoteAuthor body mfwd luActivity dep target
                _ -> return ("Unsupported offer object type for projects", Nothing)
        ResolveActivity resolve ->
            (,Nothing) <$> projectResolveF now shrRecip prjRecip remoteAuthor body mfwd luActivity resolve
        UndoActivity undo ->
            (,Nothing) <$> projectUndoF shrRecip prjRecip now remoteAuthor body mfwd luActivity undo
        _ -> return ("Unsupported activity type for projects", Nothing)
    where
    errorLocalForwarded (ActivityAuthLocalPerson pid) =
        "Project inbox got local forwarded activity by pid#" <>
        T.pack (show $ fromSqlKey pid)
    errorLocalForwarded (ActivityAuthLocalProject jid) =
        "Project inbox got local forwarded activity by jid#" <>
        T.pack (show $ fromSqlKey jid)
    errorLocalForwarded (ActivityAuthLocalRepo rid) =
        "Project inbox got local forwarded activity by rid#" <>
        T.pack (show $ fromSqlKey rid)
-}
[See repo JSON]