mirror of
https://code.naskya.net/repos/ndqEd
synced 2025-03-20 15:14:54 +09:00
247 lines
11 KiB
Haskell
247 lines
11 KiB
Haskell
{- 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.Federation
|
|
( handleActivity
|
|
)
|
|
where
|
|
|
|
import Prelude
|
|
|
|
import Control.Monad
|
|
import Control.Monad.Logger.CallStack
|
|
import Control.Monad.Trans.Except
|
|
import Control.Monad.Trans.Maybe
|
|
import Data.Aeson (Value)
|
|
import Data.Foldable
|
|
import Data.Text (Text)
|
|
import Data.Text.Encoding
|
|
import Data.Time.Clock
|
|
import Database.Persist
|
|
import Database.Persist.Sql
|
|
import Network.HTTP.Types.URI
|
|
import Yesod.Core hiding (logWarn)
|
|
import Yesod.Persist.Core
|
|
|
|
import qualified Data.Text as T
|
|
import qualified Data.Vector as V
|
|
import qualified Database.Esqueleto as E
|
|
|
|
import Network.FedURI
|
|
import Web.ActivityPub
|
|
|
|
import Database.Persist.Local
|
|
|
|
import Vervis.Foundation
|
|
import Vervis.Model
|
|
import Vervis.Settings
|
|
|
|
-- | Handle an activity that came to our inbox. Return a description of what we
|
|
-- did, and whether we stored the activity or not (so that we can decide
|
|
-- whether to log it for debugging).
|
|
handleActivity :: Value -> Text -> InstanceId -> RemoteSharerId -> Activity -> Handler (Text, Bool)
|
|
handleActivity raw hActor iidActor rsidActor (Activity _id _luActor audience specific) =
|
|
case specific of
|
|
CreateActivity (Create note) -> do
|
|
result <- runExceptT $ handleCreate iidActor hActor rsidActor raw audience note
|
|
return $
|
|
case result of
|
|
Left e -> (e, False)
|
|
Right (uNew, luTicket) ->
|
|
( T.concat
|
|
[ "Inserted remote comment <"
|
|
, renderFedURI uNew
|
|
, "> into discussion of local ticket <"
|
|
, luriPath luTicket
|
|
, ">."
|
|
]
|
|
, True
|
|
)
|
|
_ -> return ("Unsupported activity type", False)
|
|
where
|
|
toSingleton v =
|
|
case V.toList v of
|
|
[x] -> Just x
|
|
_ -> Nothing
|
|
--result t = logWarn t >> return (t, False)
|
|
done t = logWarn t >> throwE t
|
|
fromMaybeE Nothing t = done t
|
|
fromMaybeE (Just x) _ = return x
|
|
--hostIsLocal :: (MonadHandler m, HandlerSite m ~ App) => Text -> m Bool
|
|
hostIsLocal h = getsYesod $ (== h) . appInstanceHost . appSettings
|
|
verifyLocal fu t = do
|
|
let (h, lu) = f2l fu
|
|
local <- hostIsLocal h
|
|
if local
|
|
then return lu
|
|
else done t
|
|
parseAudience (Audience to bto cc bcc aud) =
|
|
case toSingleton to of
|
|
Just fu
|
|
| V.null bto && V.null cc && V.null bcc && V.null aud ->
|
|
return fu
|
|
_ -> done "Got a Create Note with a not-just-single-to audience"
|
|
local2route = parseRoute . (,[]) . decodePathSegments . encodeUtf8 . luriPath <=< noFrag
|
|
where
|
|
noFrag lu =
|
|
if T.null $ luriFragment lu
|
|
then Just lu
|
|
else Nothing
|
|
parseProject uRecip = do
|
|
let (hRecip, luRecip) = f2l uRecip
|
|
local <- hostIsLocal hRecip
|
|
unless local $ done "Got Create Note with non-local recipient"
|
|
route <- case local2route luRecip of
|
|
Nothing -> done "Got Create Note with recipient that isn't a valid route"
|
|
Just r -> return r
|
|
case route of
|
|
ProjectR shr prj -> return (shr, prj)
|
|
_ -> done "Got Create Note with non-project recipient"
|
|
parseTicket project luContext = do
|
|
route <- case local2route luContext of
|
|
Nothing -> done "Got Create Note with context that isn't a valid route"
|
|
Just r -> return r
|
|
case route of
|
|
TicketR shr prj num ->
|
|
if (shr, prj) == project
|
|
then return num
|
|
else done "Got Create Note under ticket that doesn't belong to the recipient project"
|
|
_ -> done "Got Create Note with non-ticket context"
|
|
parseParent luContext ticket uParent = do
|
|
let (hParent, luParent) = f2l uParent
|
|
local <- hostIsLocal hParent
|
|
if local
|
|
then if luParent == luContext
|
|
then return Nothing
|
|
else do
|
|
route <- case local2route luParent of
|
|
Nothing -> done "Got Create Note with local non-route parent"
|
|
Just r -> return r
|
|
case route of
|
|
TicketMessageR shr prj num hid -> do
|
|
unless (ticket == (shr, prj, num)) $
|
|
done "Got Create Note with local parent not under the same ticket as the context"
|
|
decodeHid <- getsYesod appHashidDecode
|
|
case toSqlKey <$> decodeHid hid of
|
|
Nothing -> done "Got Create Note non-existent ticket message parent hashid"
|
|
Just k -> return $ Just $ Left k
|
|
_ -> done "Got Create Note with local non-ticket-message parent"
|
|
else return $ Just $ Right (hParent, luParent)
|
|
selectOrphans uNote did op =
|
|
E.select $ E.from $ \ (rm `E.InnerJoin` m) -> do
|
|
E.on $ rm E.^. RemoteMessageRest E.==. m E.^. MessageId
|
|
E.where_ $
|
|
rm E.^. RemoteMessageLostParent E.==. E.just (E.val uNote) E.&&.
|
|
m E.^. MessageRoot `op` E.val did
|
|
return (rm E.^. RemoteMessageId, m E.^. MessageId)
|
|
handleCreate iidActor hActor rsidActor raw audience (Note luNote _luAttrib muParent muContext mpublished content) = do
|
|
(shr, prj) <- do
|
|
uRecip <- parseAudience audience
|
|
parseProject uRecip
|
|
luContext <- do
|
|
uContext <- fromMaybeE muContext "Got a Create Note without context"
|
|
verifyLocal uContext "Got a Create Note with non-local context"
|
|
num <- parseTicket (shr, prj) luContext
|
|
mparent <- do
|
|
uParent <- fromMaybeE muParent "Got a Create Note without inReplyTo"
|
|
parseParent luContext (shr, prj, num) uParent
|
|
published <- fromMaybeE mpublished "Got Create Note without 'published' field"
|
|
ExceptT $ runDB $ runExceptT $ do
|
|
mrmid <- lift $ getKeyBy $ UniqueRemoteMessageIdent iidActor luNote
|
|
for_ mrmid $ \ rmid ->
|
|
done $
|
|
"Got a Create Note with a note ID we already have, \
|
|
\RemoteMessageId " <> T.pack (show rmid)
|
|
mdid <- lift $ runMaybeT $ do
|
|
sid <- MaybeT $ getKeyBy $ UniqueSharer shr
|
|
jid <- MaybeT $ getKeyBy $ UniqueProject prj sid
|
|
t <- MaybeT $ getValBy $ UniqueTicket jid num
|
|
return $ ticketDiscuss t
|
|
did <- fromMaybeE mdid "Got Create Note on non-existent ticket"
|
|
meparent <-
|
|
case mparent of
|
|
Nothing -> return Nothing
|
|
Just parent ->
|
|
case parent of
|
|
Left lmid -> do
|
|
mlm <- lift $ get lmid
|
|
lm <- fromMaybeE mlm "Got Create Note replying to non-existent local message, no such lmid"
|
|
let mid = localMessageRest lm
|
|
m <- lift $ getJust mid
|
|
unless (messageRoot m == did) $
|
|
done "Got Create Note replying to non-existent local message, lmid not under the context ticket"
|
|
return $ Just $ Left mid
|
|
Right (hParent, luParent) -> do
|
|
mrm <- lift $ runMaybeT $ do
|
|
iid <- MaybeT $ getKeyBy $ UniqueInstance hParent
|
|
MaybeT $ getValBy $ UniqueRemoteMessageIdent iid luParent
|
|
case mrm of
|
|
Nothing -> do
|
|
logWarn "Got Create Note replying to a remote message we don't have"
|
|
return $ Just $ Right $ l2f hParent luParent
|
|
Just rm -> do
|
|
let mid = remoteMessageRest rm
|
|
m <- lift $ getJust mid
|
|
unless (messageRoot m == did) $
|
|
done "Got Create Note replying to remote message which belongs to a different discussion"
|
|
return $ Just $ Left mid
|
|
now <- liftIO getCurrentTime
|
|
rroid <- lift $ insert $ RemoteRawObject raw now
|
|
mid <- lift $ insert Message
|
|
{ messageCreated = published
|
|
, messageContent = content
|
|
, messageParent =
|
|
case meparent of
|
|
Just (Left midParent) -> Just midParent
|
|
_ -> Nothing
|
|
, messageRoot = did
|
|
}
|
|
lift $ insert_ RemoteMessage
|
|
{ remoteMessageAuthor = rsidActor
|
|
, remoteMessageInstance = iidActor
|
|
, remoteMessageIdent = luNote
|
|
, remoteMessageRest = mid
|
|
, remoteMessageRaw = rroid
|
|
, remoteMessageLostParent =
|
|
case meparent of
|
|
Just (Right uParent) -> Just uParent
|
|
_ -> Nothing
|
|
}
|
|
-- Now we need to check orphans. These are RemoteMessages whose
|
|
-- associated Message doesn't have a parent, but the original Note
|
|
-- does have an inReplyTo which isn't the same as the context. It's
|
|
-- possible that this new activity we just got, this new Note, is
|
|
-- exactly that lost parent.
|
|
let uNote = l2f hActor luNote
|
|
related <- lift $ selectOrphans uNote did (E.==.)
|
|
lift $ for_ related $ \ (E.Value rmidOrphan, E.Value midOrphan) -> do
|
|
logWarn $ T.concat
|
|
[ "Found parent for related orphan RemoteMessage #"
|
|
, T.pack (show rmidOrphan)
|
|
, ", setting its parent now to Message #"
|
|
, T.pack (show mid)
|
|
]
|
|
update rmidOrphan [RemoteMessageLostParent =. Nothing]
|
|
update midOrphan [MessageParent =. Just mid]
|
|
unrelated <- lift $ selectOrphans uNote did (E.!=.)
|
|
for_ unrelated $ \ (E.Value rmidOrphan, E.Value _midOrphan) ->
|
|
logWarn $ T.concat
|
|
[ "Found parent for unrelated orphan RemoteMessage #"
|
|
, T.pack (show rmidOrphan)
|
|
, ", NOT settings its parent to Message #"
|
|
, T.pack (show mid)
|
|
, " because they have different DiscussionId!"
|
|
]
|
|
return (uNote, luContext)
|