vervis/src/Vervis/ActivityPub.hs

{- This file is part of Vervis.
 -
 - Written in 2019 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.ActivityPub
    ( hostIsLocal
    , verifyHostLocal
    , parseContext
    , parseParent
    , runDBExcept
    , getLocalParentMessageId
    , concatRecipients
    , getPersonOrGroupId
    , getTicketTeam
    , getFollowers
    , mergeConcat
    , mergeConcat3
    , insertMany'
    , isInstanceErrorP
    , isInstanceErrorG
    , deliverHttp
    )
where

import Control.Exception hiding (try)
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.IO.Unlift
import Control.Monad.Trans.Class
import Control.Monad.Trans.Except
import Control.Monad.Trans.Reader
import Data.Bifunctor
import Data.Function
import Data.List.NonEmpty (NonEmpty, nonEmpty)
import Data.Semigroup
import Data.Text (Text)
import Data.Time.Clock
import Database.Persist
import Database.Persist.Sql
import Network.HTTP.Client
import Network.TLS -- hiding (SHA256)
import UnliftIO.Exception (try)

import qualified Data.List.NonEmpty as NE
import qualified Data.List.Ordered as LO
import qualified Database.Esqueleto as E

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

import Control.Monad.Trans.Except.Local
import Data.Either.Local
import Data.List.NonEmpty.Local
import Database.Persist.Local

import Vervis.Foundation
import Vervis.Model
import Vervis.Model.Ident
import Vervis.Settings

hostIsLocal :: (MonadSite m, SiteEnv m ~ App) => Text -> m Bool
hostIsLocal h = asksSite $ (== h) . appInstanceHost . appSettings

verifyHostLocal
    :: (MonadSite m, SiteEnv m ~ App)
    => Text -> Text -> ExceptT Text m ()
verifyHostLocal h t = do
    local <- hostIsLocal h
    unless local $ throwE t

parseContext
    :: (MonadSite m, SiteEnv m ~ App)
    => FedURI
    -> ExceptT Text m (Either (ShrIdent, PrjIdent, Int) (Text, LocalURI))
parseContext uContext = do
    let c@(hContext, luContext) = f2l uContext
    local <- hostIsLocal hContext
    if local
        then Left <$> do
            route <- case decodeRouteLocal luContext of
                Nothing -> throwE "Local context isn't a valid route"
                Just r -> return r
            case route of
                TicketR shr prj num -> return (shr, prj, num)
                _ -> throwE "Local context isn't a ticket route"
        else return $ Right c

parseParent
    :: (MonadSite m, SiteEnv m ~ App)
    => FedURI
    -> ExceptT Text m (Either (ShrIdent, LocalMessageId) (Text, LocalURI))
parseParent uParent = do
    let p@(hParent, luParent) = f2l uParent
    local <- hostIsLocal hParent
    if local
        then Left <$> do
            route <- case decodeRouteLocal luParent of
                Nothing -> throwE "Local parent isn't a valid route"
                Just r -> return r
            case route of
                MessageR shr lmkhid ->
                    (shr,) <$>
                        decodeKeyHashidE lmkhid
                            "Local parent has non-existent message \
                            \hashid"
                _ -> throwE "Local parent isn't a message route"
        else return $ Right p

newtype FedError = FedError Text deriving Show

instance Exception FedError

runDBExcept :: (MonadUnliftIO m, MonadSite m, SiteEnv m ~ App) => ExceptT Text (ReaderT SqlBackend m) a -> ExceptT Text m a
runDBExcept action = do
    result <-
        lift $ try $ runSiteDB $ either abort return =<< runExceptT action
    case result of
        Left (FedError t) -> throwE t
        Right r -> return r
    where
    abort = liftIO . throwIO . FedError

getLocalParentMessageId :: DiscussionId -> ShrIdent -> LocalMessageId -> ExceptT Text AppDB MessageId
getLocalParentMessageId did shr lmid = do
    mlm <- lift $ get lmid
    lm <- fromMaybeE mlm "Local parent: no such lmid"
    p <- lift $ getJust $ localMessageAuthor lm
    s <- lift $ getJust $ personIdent p
    unless (shr == sharerIdent s) $ throwE "Local parent: No such message, lmid mismatches sharer"
    let mid = localMessageRest lm
    m <- lift $ getJust mid
    unless (messageRoot m == did) $
        throwE "Local parent belongs to a different discussion"
    return mid

concatRecipients :: Audience -> [FedURI]
concatRecipients (Audience to bto cc bcc gen _) = concat [to, bto, cc, bcc, gen]

getPersonOrGroupId :: SharerId -> AppDB (Either PersonId GroupId)
getPersonOrGroupId sid = do
    mpid <- getKeyBy $ UniquePersonIdent sid
    mgid <- getKeyBy $ UniqueGroup sid
    requireEitherM mpid mgid
        "Found sharer that is neither person nor group"
        "Found sharer that is both person and group"

getTicketTeam :: SharerId -> AppDB ([PersonId], [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))])
getTicketTeam sid = do
    id_ <- getPersonOrGroupId sid
    (,[]) <$> case id_ of
        Left pid -> return [pid]
        Right gid ->
            map (groupMemberPerson . entityVal) <$>
                selectList [GroupMemberGroup ==. gid] []

getFollowers :: FollowerSetId -> AppDB ([PersonId], [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))])
getFollowers fsid = do
    local <- selectList [FollowTarget ==. fsid] []
    remote <- E.select $ E.from $ \ (rf `E.InnerJoin` rs `E.InnerJoin` i) -> do
        E.on $ rs E.^. RemoteActorInstance E.==. i E.^. InstanceId
        E.on $ rf E.^. RemoteFollowActor E.==. rs E.^. RemoteActorId
        E.where_ $ rf E.^. RemoteFollowTarget E.==. E.val fsid
        E.orderBy [E.asc $ i E.^. InstanceId]
        return
            ( i E.^. InstanceId
            , i E.^. InstanceHost
            , rs E.^. RemoteActorId
            , rs E.^. RemoteActorIdent
            , rs E.^. RemoteActorInbox
            , rs E.^. RemoteActorErrorSince
            )
    return
        ( map (followPerson . entityVal) local
        , groupRemotes $
            map (\ (E.Value iid, E.Value h, E.Value rsid, E.Value luActor, E.Value luInbox, E.Value msince) ->
                    (iid, h, rsid, luActor, luInbox, msince)
                )
                remote
        )
    where
    groupRemotes :: [(InstanceId, Text, RemoteActorId, LocalURI, LocalURI, Maybe UTCTime)] -> [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))]
    groupRemotes = groupWithExtractBy ((==) `on` fst) fst snd . map toTuples
        where
        toTuples (iid, h, rsid, luA, luI, ms) = ((iid, h), (rsid, luA, luI, ms))

-- | Merge 2 lists ordered on fst, concatenating snd values when
-- multiple identical fsts occur. The resulting list is ordered on fst,
-- and each fst value appears only once.
--
-- >>> mergeWith (+) [('a',3), ('a',1), ('b',5)] [('a',2), ('c',4)]
-- [('a',6), ('b',5), ('c',4)]
mergeConcat :: (Ord a, Semigroup b) => [(a, b)] -> [(a, b)] -> [(a, b)]
mergeConcat xs ys = map (second sconcat) $ groupWithExtract fst snd $ LO.mergeBy (compare `on` fst) xs ys

mergeConcat3 :: (Ord a, Semigroup b) => [(a, b)] -> [(a, b)] -> [(a, b)] -> [(a, b)]
mergeConcat3 xs ys zs = mergeConcat xs $ LO.mergeBy (compare `on` fst) ys zs

insertMany' mk xs = zip' xs <$> insertMany (NE.toList $ mk <$> xs)
    where
    zip' x y =
        case nonEmpty y of
            Just y' | length x == length y' -> NE.zip x y'
            _ -> error "insertMany' returned different length!"

isInstanceErrorHttp (InvalidUrlException _ _)    = False
isInstanceErrorHttp (HttpExceptionRequest _ hec) =
    case hec of
        ResponseTimeout -> True
        ConnectionTimeout -> True
        InternalException se ->
            case fromException se of
                Just (HandshakeFailed _) -> True
                _ -> False
        _ -> False

isInstanceErrorP (APPostErrorSig _)   = False
isInstanceErrorP (APPostErrorHTTP he) = isInstanceErrorHttp he

isInstanceErrorG Nothing  = False
isInstanceErrorG (Just e) =
    case e of
        APGetErrorHTTP he -> isInstanceErrorHttp he
        APGetErrorJSON _ -> False
        APGetErrorContentType _ -> False

deliverHttp
    :: (MonadSite m, SiteEnv m ~ App)
    => Doc Activity
    -> Maybe LocalURI
    -> Text
    -> LocalURI
    -> m (Either APPostError (Response ()))
deliverHttp doc mfwd h luInbox =
    deliverActivity (l2f h luInbox) (l2f h <$> mfwd) doc