naskya/vervis
1
0
Fork 0
mirror of https://code.naskya.net/repos/ndqEd synced 2025-03-20 15:14:54 +09:00
Code Activity
vervis/src/Vervis/Federation.hs

609 lines
27 KiB
Haskell
Raw Normal View History

Receive remote comments on local ticket discussion
2019-03-21 22:57:15 +00:00
{- 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
Rename handleActivity to handleInboxActivity
2019-03-23 15:45:44 +00:00
( handleInboxActivity
Create Note outbox handler, not in use yet I wrote a function handleOutboxNote that's supposed to do the whole outbox POST handler process. There's an outbox item table in the DB now, I adapted things in various source files. Ticket comment federation work is still in progress.
2019-03-28 21:08:30 +00:00
, handleOutboxNote
Receive remote comments on local ticket discussion
2019-03-21 22:57:15 +00:00
)
where
import Prelude
Create Note outbox handler, not in use yet I wrote a function handleOutboxNote that's supposed to do the whole outbox POST handler process. There's an outbox item table in the DB now, I adapted things in various source files. Ticket comment federation work is still in progress.
2019-03-28 21:08:30 +00:00
import Control.Concurrent.STM.TVar
import Control.Exception hiding (Handler)
Receive remote comments on local ticket discussion
2019-03-21 22:57:15 +00:00
import Control.Monad
import Control.Monad.Logger.CallStack
import Control.Monad.Trans.Except
import Control.Monad.Trans.Maybe
Switch jsonb support from persistent-postgresql to a custom module The custom module provides a parametric wrapper, allowing any specific FromJSON/ToJSON instance to be used. It's a standalone module though, and not a wrapper of persistent-postgresql, because persistent-postgresql uses aeson Value and it prevents using toEncoding to get from the value directly to a string.
2019-03-23 15:29:50 +00:00
import Data.Aeson (Object)
Receive remote comments on local ticket discussion
2019-03-21 22:57:15 +00:00
import Data.Foldable
Create Note outbox handler, not in use yet I wrote a function handleOutboxNote that's supposed to do the whole outbox POST handler process. There's an outbox item table in the DB now, I adapted things in various source files. Ticket comment federation work is still in progress.
2019-03-28 21:08:30 +00:00
import Data.List.NonEmpty (NonEmpty (..))
import Data.Maybe
Receive remote comments on local ticket discussion
2019-03-21 22:57:15 +00:00
import Data.Text (Text)
import Data.Text.Encoding
import Data.Time.Clock
Create Note outbox handler, not in use yet I wrote a function handleOutboxNote that's supposed to do the whole outbox POST handler process. There's an outbox item table in the DB now, I adapted things in various source files. Ticket comment federation work is still in progress.
2019-03-28 21:08:30 +00:00
import Data.Traversable
Receive remote comments on local ticket discussion
2019-03-21 22:57:15 +00:00
import Database.Persist
import Database.Persist.Sql
Create Note outbox handler, not in use yet I wrote a function handleOutboxNote that's supposed to do the whole outbox POST handler process. There's an outbox item table in the DB now, I adapted things in various source files. Ticket comment federation work is still in progress.
2019-03-28 21:08:30 +00:00
import Network.HTTP.Types.Header
Receive remote comments on local ticket discussion
2019-03-21 22:57:15 +00:00
import Network.HTTP.Types.URI
Create Note outbox handler, not in use yet I wrote a function handleOutboxNote that's supposed to do the whole outbox POST handler process. There's an outbox item table in the DB now, I adapted things in various source files. Ticket comment federation work is still in progress.
2019-03-28 21:08:30 +00:00
import Yesod.Core hiding (logError, logWarn, logInfo)
Receive remote comments on local ticket discussion
2019-03-21 22:57:15 +00:00
import Yesod.Persist.Core
import qualified Data.Text as T
import qualified Data.Vector as V
import qualified Database.Esqueleto as E
Create Note outbox handler, not in use yet I wrote a function handleOutboxNote that's supposed to do the whole outbox POST handler process. There's an outbox item table in the DB now, I adapted things in various source files. Ticket comment federation work is still in progress.
2019-03-28 21:08:30 +00:00
import Network.HTTP.Signature
Switch jsonb support from persistent-postgresql to a custom module The custom module provides a parametric wrapper, allowing any specific FromJSON/ToJSON instance to be used. It's a standalone module though, and not a wrapper of persistent-postgresql, because persistent-postgresql uses aeson Value and it prevents using toEncoding to get from the value directly to a string.
2019-03-23 15:29:50 +00:00
import Database.Persist.JSON
Receive remote comments on local ticket discussion
2019-03-21 22:57:15 +00:00
import Network.FedURI
import Web.ActivityPub
Create Note outbox handler, not in use yet I wrote a function handleOutboxNote that's supposed to do the whole outbox POST handler process. There's an outbox item table in the DB now, I adapted things in various source files. Ticket comment federation work is still in progress.
2019-03-28 21:08:30 +00:00
import Yesod.Auth.Unverified
import Yesod.FedURI
More type-safe handling of DB key Hashids
2019-03-29 03:25:32 +00:00
import Yesod.Hashids
Receive remote comments on local ticket discussion
2019-03-21 22:57:15 +00:00
Create Note outbox handler, not in use yet I wrote a function handleOutboxNote that's supposed to do the whole outbox POST handler process. There's an outbox item table in the DB now, I adapted things in various source files. Ticket comment federation work is still in progress.
2019-03-28 21:08:30 +00:00
import Data.Either.Local
Receive remote comments on local ticket discussion
2019-03-21 22:57:15 +00:00
import Database.Persist.Local
Create Note outbox handler, not in use yet I wrote a function handleOutboxNote that's supposed to do the whole outbox POST handler process. There's an outbox item table in the DB now, I adapted things in various source files. Ticket comment federation work is still in progress.
2019-03-28 21:08:30 +00:00
import Vervis.ActorKey
Receive remote comments on local ticket discussion
2019-03-21 22:57:15 +00:00
import Vervis.Foundation
import Vervis.Model
Create Note outbox handler, not in use yet I wrote a function handleOutboxNote that's supposed to do the whole outbox POST handler process. There's an outbox item table in the DB now, I adapted things in various source files. Ticket comment federation work is still in progress.
2019-03-28 21:08:30 +00:00
import Vervis.Model.Ident
import Vervis.RemoteActorStore
Receive remote comments on local ticket discussion
2019-03-21 22:57:15 +00:00
import Vervis.Settings
Create Note outbox handler, not in use yet I wrote a function handleOutboxNote that's supposed to do the whole outbox POST handler process. There's an outbox item table in the DB now, I adapted things in various source files. Ticket comment federation work is still in progress.
2019-03-28 21:08:30 +00:00
hostIsLocal :: (MonadHandler m, HandlerSite m ~ App) => Text -> m Bool
hostIsLocal h = getsYesod $ (== h) . appInstanceHost . appSettings
verifyHostLocal
:: (MonadHandler m, HandlerSite m ~ App)
=> Text -> Text -> ExceptT Text m ()
verifyHostLocal h t = do
local <- hostIsLocal h
unless local $ throwE t
parseAudience :: Monad m => Audience -> Text -> ExceptT Text m FedURI
parseAudience (Audience to bto cc bcc aud) t =
case toSingleton to of
Just fu
Switch Audience from Vector to list and fix Public bug * No good reason to use Vector, let's use list, it's just easier * The Public URI recognizing code wasn't being used; now it is
2019-04-01 23:40:29 +00:00
| null bto && null cc && null bcc && null aud ->
Create Note outbox handler, not in use yet I wrote a function handleOutboxNote that's supposed to do the whole outbox POST handler process. There's an outbox item table in the DB now, I adapted things in various source files. Ticket comment federation work is still in progress.
2019-03-28 21:08:30 +00:00
return fu
_ -> throwE t
where
toSingleton v =
Switch Audience from Vector to list and fix Public bug * No good reason to use Vector, let's use list, it's just easier * The Public URI recognizing code wasn't being used; now it is
2019-04-01 23:40:29 +00:00
case v of
Create Note outbox handler, not in use yet I wrote a function handleOutboxNote that's supposed to do the whole outbox POST handler process. There's an outbox item table in the DB now, I adapted things in various source files. Ticket comment federation work is still in progress.
2019-03-28 21:08:30 +00:00
[x] -> Just x
_ -> Nothing
fromMaybeE :: Monad m => Maybe a -> Text -> ExceptT Text m a
fromMaybeE Nothing t = throwE t
fromMaybeE (Just x) _ = return x
requireEitherM
:: MonadIO m => Maybe a -> Maybe b -> String -> String -> m (Either a b)
requireEitherM mx my f t =
case requireEither mx my of
Left b -> liftIO $ throwIO $ userError $ if b then t else f
Right exy -> return exy
prependError :: Monad m => Text -> ExceptT Text m a -> ExceptT Text m a
prependError t a = do
r <- lift $ runExceptT a
case r of
Left e -> throwE $ t <> ": " <> e
Right x -> return x
parseProject :: Monad m => LocalURI -> ExceptT Text m (ShrIdent, PrjIdent)
parseProject luRecip = do
route <- case decodeRouteLocal luRecip of
Nothing -> throwE "Got Create Note with recipient that isn't a valid route"
Just r -> return r
case route of
ProjectR shr prj -> return (shr, prj)
_ -> throwE "Got Create Note with non-project recipient"
parseTicket :: Monad m => (ShrIdent, PrjIdent) -> LocalURI -> ExceptT Text m Int
parseTicket project luContext = 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 ->
if (shr, prj) == project
then return num
else throwE "Local context ticket doesn't belong to the recipient project"
_ -> throwE "Local context isn't a ticket route"
parseComment :: LocalURI -> ExceptT Text Handler (ShrIdent, LocalMessageId)
parseComment luParent = do
route <- case decodeRouteLocal luParent of
Nothing -> throwE "Not a local route"
Just r -> return r
case route of
More type-safe handling of DB key Hashids
2019-03-29 03:25:32 +00:00
MessageR shr hid -> (shr,) <$> decodeKeyHashidE hid "Non-existent local message hashid"
_ -> throwE "Not a local message route"
Create Note outbox handler, not in use yet I wrote a function handleOutboxNote that's supposed to do the whole outbox POST handler process. There's an outbox item table in the DB now, I adapted things in various source files. Ticket comment federation work is still in progress.
2019-03-28 21:08:30 +00:00
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
Receive remote comments on local ticket discussion
2019-03-21 22:57:15 +00:00
-- | 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).
Rename handleActivity to handleInboxActivity
2019-03-23 15:45:44 +00:00
handleInboxActivity :: Object -> Text -> InstanceId -> RemoteSharerId -> Activity -> Handler (Text, Bool)
handleInboxActivity raw hActor iidActor rsidActor (Activity _id _luActor audience specific) =
Receive remote comments on local ticket discussion
2019-03-21 22:57:15 +00:00
case specific of
CreateActivity (Create note) -> do
result <- runExceptT $ handleCreate iidActor hActor rsidActor raw audience note
Create Note outbox handler, not in use yet I wrote a function handleOutboxNote that's supposed to do the whole outbox POST handler process. There's an outbox item table in the DB now, I adapted things in various source files. Ticket comment federation work is still in progress.
2019-03-28 21:08:30 +00:00
case result of
Left e -> logWarn e >> return ("Create Note: " <> e, False)
Right (uNew, luTicket) ->
return
Receive remote comments on local ticket discussion
2019-03-21 22:57:15 +00:00
( T.concat
[ "Inserted remote comment <"
, renderFedURI uNew
, "> into discussion of local ticket <"
, luriPath luTicket
, ">."
]
, True
)
_ -> return ("Unsupported activity type", False)
where
verifyLocal fu t = do
let (h, lu) = f2l fu
local <- hostIsLocal h
if local
then return lu
Create Note outbox handler, not in use yet I wrote a function handleOutboxNote that's supposed to do the whole outbox POST handler process. There's an outbox item table in the DB now, I adapted things in various source files. Ticket comment federation work is still in progress.
2019-03-28 21:08:30 +00:00
else throwE t
parseParent :: LocalURI -> FedURI -> ExceptT Text Handler (Maybe (Either (ShrIdent, LocalMessageId) (Text, LocalURI)))
parseParent luContext uParent = do
Receive remote comments on local ticket discussion
2019-03-21 22:57:15 +00:00
let (hParent, luParent) = f2l uParent
local <- hostIsLocal hParent
if local
then if luParent == luContext
then return Nothing
Create Note outbox handler, not in use yet I wrote a function handleOutboxNote that's supposed to do the whole outbox POST handler process. There's an outbox item table in the DB now, I adapted things in various source files. Ticket comment federation work is still in progress.
2019-03-28 21:08:30 +00:00
else prependError "Local parent" $ Just . Left <$> parseComment luParent
Receive remote comments on local ticket discussion
2019-03-21 22:57:15 +00:00
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)
Add noteAudience; record recipient of local remotely-targetted activities in DB
2019-03-23 02:57:34 +00:00
handleCreate iidActor hActor rsidActor raw audience (Note mluNote _luAttrib _aud muParent muContext mpublished content) = do
Make noteId optional, to support taking a Note in postOutboxR
2019-03-23 02:05:30 +00:00
luNote <- fromMaybeE mluNote "Got Create Note without note id"
Receive remote comments on local ticket discussion
2019-03-21 22:57:15 +00:00
(shr, prj) <- do
Create Note outbox handler, not in use yet I wrote a function handleOutboxNote that's supposed to do the whole outbox POST handler process. There's an outbox item table in the DB now, I adapted things in various source files. Ticket comment federation work is still in progress.
2019-03-28 21:08:30 +00:00
(hRecip, luRecip) <- f2l <$> parseAudience audience "Got a Create Note with a not-just-single-to audience"
verifyHostLocal hRecip "Non-local recipient"
parseProject luRecip
Receive remote comments on local ticket discussion
2019-03-21 22:57:15 +00:00
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"
Create Note outbox handler, not in use yet I wrote a function handleOutboxNote that's supposed to do the whole outbox POST handler process. There's an outbox item table in the DB now, I adapted things in various source files. Ticket comment federation work is still in progress.
2019-03-28 21:08:30 +00:00
parseParent luContext uParent
Receive remote comments on local ticket discussion
2019-03-21 22:57:15 +00:00
published <- fromMaybeE mpublished "Got Create Note without 'published' field"
ExceptT $ runDB $ runExceptT $ do
mrmid <- lift $ getKeyBy $ UniqueRemoteMessageIdent iidActor luNote
for_ mrmid $ \ rmid ->
Create Note outbox handler, not in use yet I wrote a function handleOutboxNote that's supposed to do the whole outbox POST handler process. There's an outbox item table in the DB now, I adapted things in various source files. Ticket comment federation work is still in progress.
2019-03-28 21:08:30 +00:00
throwE $
Receive remote comments on local ticket discussion
2019-03-21 22:57:15 +00:00
"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"
Create Note outbox handler, not in use yet I wrote a function handleOutboxNote that's supposed to do the whole outbox POST handler process. There's an outbox item table in the DB now, I adapted things in various source files. Ticket comment federation work is still in progress.
2019-03-28 21:08:30 +00:00
meparent <- for mparent $ \ parent ->
case parent of
Left (shrParent, lmid) -> Left <$> getLocalParentMessageId did shrParent lmid
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 $ Right $ l2f hParent luParent
Just rm -> do
let mid = remoteMessageRest rm
Receive remote comments on local ticket discussion
2019-03-21 22:57:15 +00:00
m <- lift $ getJust mid
unless (messageRoot m == did) $
Create Note outbox handler, not in use yet I wrote a function handleOutboxNote that's supposed to do the whole outbox POST handler process. There's an outbox item table in the DB now, I adapted things in various source files. Ticket comment federation work is still in progress.
2019-03-28 21:08:30 +00:00
throwE "Got Create Note replying to remote message which belongs to a different discussion"
return $ Left mid
Receive remote comments on local ticket discussion
2019-03-21 22:57:15 +00:00
now <- liftIO getCurrentTime
Switch jsonb support from persistent-postgresql to a custom module The custom module provides a parametric wrapper, allowing any specific FromJSON/ToJSON instance to be used. It's a standalone module though, and not a wrapper of persistent-postgresql, because persistent-postgresql uses aeson Value and it prevents using toEncoding to get from the value directly to a string.
2019-03-23 15:29:50 +00:00
rroid <- lift $ insert $ RemoteRawObject (PersistJSON raw) now
Receive remote comments on local ticket discussion
2019-03-21 22:57:15 +00:00
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
Add route getMessageR, returns an Activity Note for any locally created Message
2019-03-22 20:46:42 +00:00
, remoteMessageRaw = rroid
Receive remote comments on local ticket discussion
2019-03-21 22:57:15 +00:00
, 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)
Create Note outbox handler, not in use yet I wrote a function handleOutboxNote that's supposed to do the whole outbox POST handler process. There's an outbox item table in the DB now, I adapted things in various source files. Ticket comment federation work is still in progress.
2019-03-28 21:08:30 +00:00
-- | Handle a Note submitted by a local user to their outbox. It can be either
-- a comment on a local ticket, or a comment on some remote context. Return an
-- error message if the Note is rejected, otherwise the new 'LocalMessageId'.
handleOutboxNote :: Text -> Note -> Handler (Either Text LocalMessageId)
handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished content) = runExceptT $ do
verifyHostLocal host "Attributed to non-local actor"
verifyNothing mluNote "Note specifies an id"
verifyNothing mpublished "Note specifies published"
uContext <- fromMaybeE muContext "Note without context"
uRecip <- parseAudience aud "Note has not-just-single-to audience"
recipContextParent <- parseRecipContextParent uRecip uContext muParent
(lmid, mdeliver) <- ExceptT $ runDB $ runExceptT $ do
(pid, shrUser) <- verifyIsLoggedInUser luAttrib "Note attributed to different actor"
case recipContextParent of
(mparent, Left (shr, prj, num)) -> do
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 "Context: No such local ticket"
mmidParent <- for mparent $ \ parent ->
case parent of
Left (shrParent, lmidParent) -> getLocalParentMessageId did shrParent lmidParent
Right (hParent, luParent) -> do
mrm <- lift $ runMaybeT $ do
iid <- MaybeT $ getKeyBy $ UniqueInstance hParent
MaybeT $ getValBy $ UniqueRemoteMessageIdent iid luParent
rm <- fromMaybeE mrm "Remote parent unknown locally"
let mid = remoteMessageRest rm
m <- lift $ getJust mid
unless (messageRoot m == did) $
throwE "Remote parent belongs to a different discussion"
return mid
let meparent = Left <$> mmidParent
(lmid, _doc) <- lift $ insertMessage luAttrib shrUser pid uContext did muParent meparent content
return (lmid, Nothing)
(mparent, Right (hRecip, luRecip, luContext)) -> do
(did, rdid, rdnew, mluInbox) <- do
miid <- lift $ getKeyBy $ UniqueInstance hRecip
erd <-
case miid of
Just iid -> findExistingRemoteDiscussion iid hRecip luRecip luContext
Nothing -> return Nothing
case erd of
Just (d, rd, minb) -> return (d, rd, False, minb)
Nothing -> ExceptT $ withHostLock hRecip $ runExceptT $ storeRemoteDiscussion miid hRecip luRecip luContext
meparent <- for mparent $ \ parent ->
case parent of
Left (shrParent, lmidParent) -> do
when rdnew $ throwE "Local parent inexistent, RemoteDiscussion is new"
Left <$> getLocalParentMessageId did shrParent lmidParent
Right (hParent, luParent) -> do
mrm <- lift $ runMaybeT $ do
iid <- MaybeT $ getKeyBy $ UniqueInstance hParent
MaybeT $ getValBy $ UniqueRemoteMessageIdent iid luParent
case mrm of
Nothing -> return $ Right $ l2f hParent luParent
Just rm -> Left <$> do
let mid = remoteMessageRest rm
m <- lift $ getJust mid
unless (messageRoot m == did) $
throwE "Remote parent belongs to a different discussion"
return mid
(lmid, doc) <- lift $ insertMessage luAttrib shrUser pid uContext did muParent meparent content
return (lmid, Just (doc, hRecip, maybe (Right (luRecip, rdid)) Left mluInbox))
let handleDeliverError e = logError $ "Outbox POST handler: delivery failed! " <> T.pack (displayException e)
lift $ for_ mdeliver $ \ (doc, hRecip, einb) -> forkHandler handleDeliverError $ do
uInbox <-
case einb of
Left luInbox -> return $ l2f hRecip luInbox
Right (luRecip, rdid) -> do
mluInbox <- runDB $ runMaybeT $ do
iid <- MaybeT $ getKeyBy $ UniqueInstance hRecip
rs <- MaybeT $ getValBy $ UniqueRemoteSharer iid luRecip
return $ remoteSharerInbox rs
case mluInbox of
Just luInbox -> return $ l2f hRecip luInbox
Nothing -> do
manager <- getsYesod appHttpManager
eactor <- fetchAPID manager actorId hRecip luRecip
case eactor of
Left s -> fail $ "Fetched recipient actor: " ++ s
Right actor -> withHostLock hRecip $ runDB $ do
iid <- either entityKey id <$> insertBy (Instance hRecip)
let luInbox = actorInbox actor
rsid <- either entityKey id <$> insertBy (RemoteSharer luRecip iid luInbox)
update rdid [RemoteDiscussionActor =. Just rsid, RemoteDiscussionUnlinkedActor =. Nothing]
return $ l2f hRecip luInbox
-- TODO based on the httpPostAP usage in postOutboxR
manager <- getsYesod appHttpManager
(akey1, akey2, new1) <- liftIO . readTVarIO =<< getsYesod appActorKeys
renderUrl <- getUrlRender
let (keyID, akey) =
if new1
then (renderUrl ActorKey1R, akey1)
else (renderUrl ActorKey2R, akey2)
sign b = (KeyId $ encodeUtf8 keyID, actorKeySign akey b)
actorID = renderFedURI $ l2f host luAttrib
eres <- httpPostAP manager uInbox (hRequestTarget :| [hHost, hDate, hActivityPubActor]) sign actorID doc
case eres of
Left e -> logError $ "Failed to POST to recipient's inbox: " <> T.pack (displayException e)
Right _ -> logInfo $ T.concat
[ "Successful delivery of <"
, renderFedURI $ l2f (docHost doc) (activityId $ docValue doc)
, " to <"
, renderFedURI uRecip
, ">"
]
return lmid
where
verifyNothing :: Monad m => Maybe a -> Text -> ExceptT Text m ()
verifyNothing Nothing _ = return ()
verifyNothing (Just _) t = throwE t
verifySameHost
:: Monad m => Text -> FedURI -> Text -> ExceptT Text m LocalURI
verifySameHost h fu t = do
let (h', lu) = f2l fu
if h == h'
then return lu
else throwE t
parseRecipContextParent
:: FedURI
-> FedURI
-> Maybe FedURI
-> ExceptT
Text
Handler
( Maybe (Either (ShrIdent, LocalMessageId) (Text, LocalURI))
, Either
(ShrIdent, PrjIdent, Int)
(Text, LocalURI, LocalURI)
)
parseRecipContextParent uRecip uContext muParent = do
let r@(hRecip, luRecip) = f2l uRecip
luContext <- verifySameHost hRecip uContext "Recipient and context on different hosts"
meparent <-
case muParent of
Nothing -> return Nothing
Just uParent ->
if uParent == uContext
then return Nothing
else Just <$> do
let (hParent, luParent) = f2l uParent
parentLocal <- hostIsLocal hParent
if parentLocal
then Left <$> parseComment luParent
else return $ Right (hParent, luParent)
local <- hostIsLocal hRecip
if local
then do
(shr, prj) <- parseProject luRecip
num <- parseTicket (shr, prj) luContext
return (meparent, Left (shr, prj, num))
else do
when (luRecip == luContext) $
throwE "Identical recipient and context"
{-
mrs <- lift $ runDB $ runMaybeT $ do
iid <- MaybeT $ getKeyBy $ UniqueInstance hRecip
MaybeT $ getBy $ UniqueRemoteSharer iid luRecip
erecip <-
case mrs of
Just ers -> return $ Left ers
Nothing -> do
manager <- getsYesod appHttpManager
eactor <- fetchAPID manager actorId hRecip luRecip
case eactor of
Left s -> throwE $ "Fetched recipient actor: " <> T.pack s
Right actor -> return $ Right actor
-}
return (meparent, Right (hRecip, luRecip, luContext))
verifyIsLoggedInUser
:: LocalURI -> Text -> ExceptT Text AppDB (PersonId, ShrIdent)
verifyIsLoggedInUser lu t = do
Entity pid p <- requireVerifiedAuth
s <- lift $ getJust $ personIdent p
route2local <- getEncodeRouteLocal
let shr = sharerIdent s
if route2local (SharerR shr) == lu
then return (pid, shr)
else throwE t
findExistingRemoteDiscussion
:: InstanceId
-> Text
-> LocalURI
-> LocalURI
-> ExceptT Text AppDB
(Maybe (DiscussionId, RemoteDiscussionId, Maybe LocalURI))
findExistingRemoteDiscussion iid hRecip luRecip luContext = do
merd <- lift $ getBy $ UniqueRemoteDiscussionIdent iid luContext
for merd $ \ (Entity rdid rd) -> do
eactor <-
requireEitherM
(remoteDiscussionActor rd)
(remoteDiscussionUnlinkedActor rd)
"RemoteDiscussion actor and unlinkedActor both unset"
"RemoteDiscussion actor and unlinkedActor both set"
minb <- case eactor of
Left rsid -> do
rs <- lift $ getJust rsid
unless (remoteSharerInstance rs == iid && remoteSharerIdent rs == luRecip) $
throwE "Known remote context, but its actor doesn't match the new Note's recipient"
return $ Just $ remoteSharerInbox rs
Right uActor -> do
unless (uActor == l2f hRecip luRecip) $
throwE "Known remote context, but its unlinked actor doesn't match the new Note's recipient"
return Nothing
return (remoteDiscussionDiscuss rd, rdid, minb)
insertRemoteDiscussion
:: InstanceId
-> Bool
-> Text
-> LocalURI
-> LocalURI
-> AppDB (DiscussionId, RemoteDiscussionId, Maybe LocalURI)
insertRemoteDiscussion iid inew hRecip luRecip luContext = do
mrs <-
if inew
then return Nothing
else getBy $ UniqueRemoteSharer iid luRecip
did <- insert Discussion
rdid <- insert RemoteDiscussion
{ remoteDiscussionActor = entityKey <$> mrs
, remoteDiscussionInstance = iid
, remoteDiscussionIdent = luContext
, remoteDiscussionDiscuss = did
, remoteDiscussionUnlinkedActor =
case mrs of
Nothing -> Just $ l2f hRecip luRecip
Just _ -> Nothing
}
return (did, rdid, remoteSharerInbox . entityVal <$> mrs)
storeRemoteDiscussion
:: Maybe InstanceId
-> Text
-> LocalURI
-> LocalURI
-> ExceptT Text AppDB
(DiscussionId, RemoteDiscussionId, Bool, Maybe LocalURI)
storeRemoteDiscussion miid hRecip luRecip luContext = do
(iid, inew) <-
case miid of
Just i -> return (i, False)
Nothing -> lift $ idAndNew <$> insertBy (Instance hRecip)
if inew
then do
(did, rdid, minb) <- lift $ insertRemoteDiscussion iid True hRecip luRecip luContext
return (did, rdid, True, minb)
else do
erd <- findExistingRemoteDiscussion iid hRecip luRecip luContext
case erd of
Just (did, rdid, minb) -> return (did, rdid, False, minb)
Nothing -> do
(did, rdid, minb) <- lift $ insertRemoteDiscussion iid False hRecip luRecip luContext
return (did, rdid, True, minb)
insertMessage
:: LocalURI
-> ShrIdent
-> PersonId
-> FedURI
-> DiscussionId
-> Maybe FedURI
-> Maybe (Either MessageId FedURI)
-> Text
-> AppDB (LocalMessageId, Doc Activity)
insertMessage luAttrib shrUser pid uContext did muParent meparent content = do
now <- liftIO getCurrentTime
mid <- insert Message
{ messageCreated = now
, messageContent = content
, messageParent =
case meparent of
Just (Left midParent) -> Just midParent
_ -> Nothing
, messageRoot = did
}
lmid <- insert LocalMessage
{ localMessageAuthor = pid
, localMessageRest = mid
, localMessageUnlinkedParent =
case meparent of
Just (Right uParent) -> Just uParent
_ -> Nothing
}
route2local <- getEncodeRouteLocal
More type-safe handling of DB key Hashids
2019-03-29 03:25:32 +00:00
lmhid <- encodeKeyHashid lmid
Create Note outbox handler, not in use yet I wrote a function handleOutboxNote that's supposed to do the whole outbox POST handler process. There's an outbox item table in the DB now, I adapted things in various source files. Ticket comment federation work is still in progress.
2019-03-28 21:08:30 +00:00
let activity luAct = Doc host Activity
{ activityId = luAct
, activityActor = luAttrib
, activityAudience = aud
, activitySpecific = CreateActivity Create
{ createObject = Note
More type-safe handling of DB key Hashids
2019-03-29 03:25:32 +00:00
{ noteId = Just $ route2local $ MessageR shrUser lmhid
Create Note outbox handler, not in use yet I wrote a function handleOutboxNote that's supposed to do the whole outbox POST handler process. There's an outbox item table in the DB now, I adapted things in various source files. Ticket comment federation work is still in progress.
2019-03-28 21:08:30 +00:00
, noteAttrib = luAttrib
, noteAudience = aud
, noteReplyTo = Just $ fromMaybe uContext muParent
, noteContext = Just uContext
, notePublished = Just now
, noteContent = content
}
}
}
obid <- insert OutboxItem
{ outboxItemPerson = pid
, outboxItemActivity = PersistJSON $ activity $ LocalURI "" ""
, outboxItemPublished = now
}
More type-safe handling of DB key Hashids
2019-03-29 03:25:32 +00:00
obhid <- encodeKeyHashid obid
let luAct = route2local $ OutboxItemR shrUser obhid
Create Note outbox handler, not in use yet I wrote a function handleOutboxNote that's supposed to do the whole outbox POST handler process. There's an outbox item table in the DB now, I adapted things in various source files. Ticket comment federation work is still in progress.
2019-03-28 21:08:30 +00:00
doc = activity luAct
update obid [OutboxItemActivity =. PersistJSON doc]
return (lmid, doc)
Copy permalink