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
    , deliverRemoteDB
    , deliverRemoteHTTP
    , checkForward
    )
where

import Control.Exception hiding (Handler, try)
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.IO.Unlift
import Control.Monad.Logger.CallStack
import Control.Monad.Trans.Class
import Control.Monad.Trans.Except
import Control.Monad.Trans.Reader
import Data.Bifunctor
import Data.ByteString (ByteString)
import Data.Foldable
import Data.Function
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.Traversable
import Database.Persist
import Database.Persist.Sql
import Network.HTTP.Client
import Network.TLS -- hiding (SHA256)
import UnliftIO.Exception (try)
import Yesod.Core.Handler
import Yesod.Persist.Core

import qualified Data.ByteString.Lazy as BL
import qualified Data.CaseInsensitive as CI
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 Yesod.HttpSignature

import Network.FedURI
import Network.HTTP.Digest
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 Data.Tuple.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

deliverRemoteDB
    :: BL.ByteString
    -> RemoteActivityId
    -> ProjectId
    -> ByteString
    -> [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))]
    -> AppDB
        [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId))]
deliverRemoteDB body ractid jid sig recips = do
    let body' = BL.toStrict body
        deliv raid msince = Forwarding raid ractid body' jid sig $ isNothing msince
    fetchedDeliv <- for recips $ \ (i, rs) ->
        (i,) <$> insertMany' (\ (raid, _, _, msince) -> deliv raid msince) rs
    return $ takeNoError4 fetchedDeliv
    where
    takeNoError noError = mapMaybe $ \ (i, rs) -> (i,) <$> nonEmpty (mapMaybe noError $ NE.toList rs)
    takeNoError4 = takeNoError noError
        where
        noError ((ak, luA, luI, Nothing), dlk) = Just (ak, luA, luI, dlk)
        noError ((_ , _  , _  , Just _ ), _  ) = Nothing

deliverRemoteHTTP
    :: UTCTime
    -> ShrIdent
    -> PrjIdent
    -> BL.ByteString
    -> ByteString
    -> [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId))]
    -> Handler ()
deliverRemoteHTTP now shrRecip prjRecip body sig fetched = do
    let deliver h inbox =
            let sender = ProjectR shrRecip prjRecip
            in  forwardActivity (l2f h inbox) sig sender body
    traverse_ (fork . deliverFetched deliver now) fetched
    where
    fork = forkHandler $ \ e -> logError $ "Project inbox handler: delivery failed! " <> T.pack (displayException e)
    deliverFetched deliver now ((_, h), recips@(r :| rs)) = do
        let (raid, _luActor, luInbox, fwid) = r
        e <- deliver h luInbox
        let e' = case e of
                    Left err ->
                        if isInstanceErrorP err
                            then Nothing
                            else Just False
                    Right _resp -> Just True
        case e' of
            Nothing -> runDB $ do
                let recips' = NE.toList recips
                updateWhere [RemoteActorId <-. map fst4 recips', RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now]
                updateWhere [ForwardingId <-. map fourth4 recips'] [ForwardingRunning =. False]
            Just success -> do
                runDB $
                    if success
                        then delete fwid
                        else do
                            updateWhere [RemoteActorId ==. raid, RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now]
                            update fwid [ForwardingRunning =. False]
                for_ rs $ \ (raid, _luActor, luInbox, fwid) ->
                    fork $ do
                        e <- deliver h luInbox
                        runDB $
                            case e of
                                Left _err -> do
                                    updateWhere [RemoteActorId ==. raid, RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now]
                                    update fwid [ForwardingRunning =. False]
                                Right _resp -> delete fwid

checkForward shrRecip prjRecip = join <$> do
    let hSig = hForwardingSignature
    msig <- maybeHeader hSig
    for msig $ \ sig -> do
        _proof <- withExceptT (T.pack . displayException) $ ExceptT $
            let requires = [hDigest, hActivityPubForwarder]
            in  prepareToVerifyHttpSigWith hSig False requires [] Nothing
        forwarder <- requireHeader hActivityPubForwarder
        renderUrl <- getUrlRender
        let project = renderUrl $ ProjectR shrRecip prjRecip
        return $
            if forwarder == encodeUtf8 project
                then Just sig
                else Nothing
    where
    maybeHeader n = do
        let n' = decodeUtf8 $ CI.original n
        hs <- lookupHeaders n
        case hs of
            [] -> return Nothing
            [h] -> return $ Just h
            _ -> throwE $ n' <> " multiple headers found"
    requireHeader n = do
        let n' = decodeUtf8 $ CI.original n
        mh <- maybeHeader n
        case mh of
            Nothing -> throwE $ n' <> " header not found"
            Just h -> return h