Implement sharer inbox handler

It runs checks against all the relevant tables, but ultimately just inserts the
activity into the recipient's inbox and nothing more, leaving the RemoteMessage
creation and inbox forwarding to the project inbox handler.
This commit is contained in:
fr33domlover 2019-04-23 02:57:53 +00:00
parent e06f40b665
commit f462a67680
7 changed files with 222 additions and 110 deletions

View file

@ -12,10 +12,6 @@
-- with this software. If not, see
-- <http://creativecommons.org/publicdomain/zero/1.0/>.
RemoteRawObject
content PersistJSONObject
received UTCTime
-------------------------------------------------------------------------------
-- People
-------------------------------------------------------------------------------
@ -54,6 +50,20 @@ InboxItemLocal
UniqueInboxItemLocal person activity
RemoteActivity
instance InstanceId
ident LocalURI
content PersistJSONObject
received UTCTime
UniqueRemoteActivity instance ident
InboxItemRemote
person PersonId
activity RemoteActivityId
UniqueInboxItemRemote person activity
UnlinkedDelivery
recipient UnfetchedRemoteActorId
activity OutboxItemId
@ -299,7 +309,7 @@ RemoteMessage
instance InstanceId
ident LocalURI
rest MessageId
raw RemoteRawObjectId
create RemoteActivityId
lostParent FedURI Maybe
UniqueRemoteMessageIdent instance ident

View file

@ -0,0 +1,13 @@
RemoteActivity
instance InstanceId
ident Text
content PersistJSONValue
received UTCTime
UniqueRemoteActivity instance ident
InboxItemRemote
person PersonId
activity RemoteActivityId
UniqueInboxItemRemote person activity

View file

@ -14,7 +14,7 @@
-}
module Vervis.Federation
( handleInboxActivity
( handleSharerInbox
, fixRunningDeliveries
, handleOutboxNote
, retryOutboxDelivery
@ -79,6 +79,7 @@ import Data.List.Local
import Data.List.NonEmpty.Local
import Data.Maybe.Local
import Database.Persist.Local
import Yesod.Persist.Local
import Vervis.ActorKey
import Vervis.Foundation
@ -171,29 +172,120 @@ getLocalParentMessageId did shr lmid = do
throwE "Local parent belongs to a different discussion"
return mid
-- | 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).
handleInboxActivity :: Object -> Text -> InstanceId -> RemoteActorId -> Activity -> Handler (Text, Bool)
handleInboxActivity 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
case result of
Left e -> logWarn e >> return ("Create Note: " <> e, False)
Right (uNew, luTicket) ->
return
( T.concat
[ "Inserted remote comment <"
, renderFedURI uNew
, "> into discussion of local ticket <"
, luriPath luTicket
, ">."
]
, True
)
_ -> return ("Unsupported activity type", False)
handleSharerInbox
:: UTCTime
-> ShrIdent
-> InstanceId
-> Object
-> Activity
-> ExceptT Text Handler Text
handleSharerInbox now shrRecip iidSender raw activity =
case activitySpecific activity of
CreateActivity (Create note) -> handleNote note
_ -> return "Unsupported activity type"
where
handleNote (Note mluNote _ _ muParent muContext mpublished content) = do
_luNote <- fromMaybeE mluNote "Note without note id"
_published <- fromMaybeE mpublished "Note without 'published' field"
uContext <- fromMaybeE muContext "Note without context"
context <- parseContext uContext
mparent <-
case muParent of
Nothing -> return Nothing
Just uParent ->
if uParent == uContext
then return Nothing
else Just <$> parseParent uParent
ExceptT $ runDB $ do
pidRecip <- do
sid <- getKeyBy404 $ UniqueSharer shrRecip
getKeyBy404 $ UniquePersonIdent sid
valid <- checkContextParent context mparent
case valid of
Left e -> return $ Left e
Right _ -> Right <$> insertToInbox pidRecip
where
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 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
checkContextParent context mparent = runExceptT $ do
case context of
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"
for_ mparent $ \ parent ->
case parent of
Left (shrP, lmidP) ->
void $ getLocalParentMessageId did shrP lmidP
Right (hParent, luParent) -> do
mrm <- lift $ runMaybeT $ do
iid <- MaybeT $ getKeyBy $ UniqueInstance hParent
MaybeT $ getValBy $ UniqueRemoteMessageIdent iid luParent
for_ mrm $ \ rm -> do
let mid = remoteMessageRest rm
m <- lift $ getJust mid
unless (messageRoot m == did) $
throwE "Remote parent belongs to a different discussion"
Right (hContext, luContext) -> do
mdid <- lift $ runMaybeT $ do
iid <- MaybeT $ getKeyBy $ UniqueInstance hContext
rd <- MaybeT $ getValBy $ UniqueRemoteDiscussionIdent iid luContext
return $ remoteDiscussionDiscuss rd
for_ mparent $ \ parent ->
case parent of
Left (shrP, lmidP) -> do
did <- fromMaybeE mdid "Local parent inexistent, no RemoteDiscussion"
void $ getLocalParentMessageId did shrP lmidP
Right (hParent, luParent) -> do
mrm <- lift $ runMaybeT $ do
iid <- MaybeT $ getKeyBy $ UniqueInstance hParent
MaybeT $ getValBy $ UniqueRemoteMessageIdent iid luParent
for_ mrm $ \ rm -> do
let mid = remoteMessageRest rm
m <- lift $ getJust mid
did <- fromMaybeE mdid "Remote parent known, but no context RemoteDiscussion"
unless (messageRoot m == did) $
throwE "Remote parent belongs to a different discussion"
insertToInbox pidRecip = do
let luActivity = activityId activity
jsonObj = PersistJSON raw
ract = RemoteActivity iidSender luActivity jsonObj now
ractid <- either entityKey id <$> insertBy' ract
mibrid <- insertUnique $ InboxItemRemote pidRecip ractid
let recip = shr2text shrRecip
return $ case mibrid of
Nothing -> "Activity already exists in inbox of /s/" <> recip
Just _ -> "Activity inserted to inbox of /s/" <> recip
{-
verifyLocal fu t = do
let (h, lu) = f2l fu
local <- hostIsLocal h
@ -217,19 +309,6 @@ handleInboxActivity raw hActor iidActor rsidActor (Activity _id _luActor audienc
m E.^. MessageRoot `op` E.val did
return (rm E.^. RemoteMessageId, m E.^. MessageId)
handleCreate iidActor hActor rsidActor raw audience (Note mluNote _luAttrib _aud muParent muContext mpublished content) = do
luNote <- fromMaybeE mluNote "Got Create Note without note id"
(shr, prj) <- do
(hRecip, luRecip) <- f2l <$> parseAudience audience "Got a Create Note with a not-just-single-to audience"
verifyHostLocal hRecip "Non-local recipient"
parseProject luRecip
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 uParent
published <- fromMaybeE mpublished "Got Create Note without 'published' field"
ExceptT $ runDB $ runExceptT $ do
mrmid <- lift $ getKeyBy $ UniqueRemoteMessageIdent iidActor luNote
for_ mrmid $ \ rmid ->
@ -307,6 +386,7 @@ handleInboxActivity raw hActor iidActor rsidActor (Activity _id _luActor audienc
, " because they have different DiscussionId!"
]
return (uNote, luContext)
-}
fixRunningDeliveries :: (MonadIO m, MonadLogger m, IsSqlBackend backend) => ReaderT backend m ()
fixRunningDeliveries = do

View file

@ -85,11 +85,12 @@ import Vervis.Model.Role
import Vervis.RemoteActorStore
import Vervis.Widget (breadcrumbsW, revisionW)
data ActivityReport
= ActivityReportHandlerError String
| ActivityReportWorkerError ByteString BL.ByteString SomeException
| ActivityReportUsed Text
| ActivityReportUnused ByteString BL.ByteString Text
data ActivityReport = ActivityReport
{ _arTime :: UTCTime
, _arMessage :: Text
, _arContentTypes :: [ContentType]
, _arBody :: BL.ByteString
}
-- | The foundation datatype for your application. This can be a good place to
-- keep settings and values requiring initialization before your application
@ -109,7 +110,7 @@ data App = App
, appHashidsContext :: HashidsContext
, appActorFetchShare :: ActorFetchShare App
, appActivities :: TVar (Vector (UTCTime, ActivityReport))
, appActivities :: TVar (Vector ActivityReport)
}
-- Aliases for the routes file, because it doesn't like spaces in path piece

View file

@ -45,11 +45,12 @@ import Data.Aeson
import Data.Bifunctor (first, second)
import Data.Foldable (for_)
import Data.HashMap.Strict (HashMap)
import Data.List
import Data.List.NonEmpty (NonEmpty (..))
import Data.Maybe
import Data.PEM (PEM (..))
import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8)
import Data.Text.Encoding (encodeUtf8, decodeUtf8')
import Data.Text.Lazy.Encoding (decodeUtf8)
import Data.Time.Clock (UTCTime, getCurrentTime)
import Data.Time.Interval (TimeInterval, toTimeUnit)
@ -58,6 +59,7 @@ import Database.Persist (Entity (..), getBy, insertBy, insert_)
import Network.HTTP.Client (Manager, HttpException, requestFromURI)
import Network.HTTP.Simple (httpJSONEither, getResponseBody, setRequestManager, addRequestHeader)
import Network.HTTP.Types.Header (hDate, hHost)
import Network.HTTP.Types.Status
import Text.Blaze.Html (Html)
import Text.Shakespeare.I18N (RenderMessage)
import UnliftIO.Exception (try)
@ -84,7 +86,7 @@ import Yesod.HttpSignature (verifyRequestSignature)
import qualified Network.HTTP.Signature as S (Algorithm (..))
import Data.Aeson.Encode.Pretty.ToEncoding
import Data.Aeson.Encode.Pretty
import Data.Aeson.Local
import Database.Persist.Local
import Network.FedURI
@ -117,23 +119,12 @@ getInboxR = do
with a report of what exactly happened.
<p>Last 10 activities posted:
<ul>
$forall (time, report) <- acts
$forall ActivityReport time msg ctypes body <- acts
<li>
<div>#{show time}
$case report
$of ActivityReportHandlerError e
<div>Handler error:
<div>#{e}
$of ActivityReportWorkerError ct o e
<div><code>#{BC.unpack ct}
<div><pre>#{decodeUtf8 o}
<div>#{displayException e}
$of ActivityReportUsed msg
<div>#{msg}
$of ActivityReportUnused ct o msg
<div><code>#{BC.unpack ct}
<div><pre>#{decodeUtf8 o}
<div>#{msg}
<div>#{msg}
<div><code>#{intercalate " | " $ map BC.unpack ctypes}
<div><pre>#{decodeUtf8 body}
|]
getSharerInboxR :: ShrIdent -> Handler TypedContent
@ -142,61 +133,66 @@ getSharerInboxR _ = error "TODO implement getSharerInboxR"
getProjectInboxR :: ShrIdent -> PrjIdent -> Handler TypedContent
getProjectInboxR _ _ = error "TODO implement getProjectInboxR"
postInboxR :: Handler ()
postInboxR = do
postSharerInboxR :: ShrIdent -> Handler ()
postSharerInboxR shrRecip = do
federation <- getsYesod $ appFederation . appSettings
unless federation badMethod
contentTypes <- lookupHeaders "Content-Type"
body <- requireJsonBody
now <- liftIO getCurrentTime
r <- runExceptT $ getActivity now
case r of
Right (ct, (WithValue raw d@(Doc h a), (iid, rsid))) ->
forkHandler (handleWorkerError now ct d) $ do
(msg, stored) <- handleInboxActivity raw h iid rsid a
if stored
then recordUsed now msg
else recordUnused now ct d msg
Left e -> do
recordError now e
notAuthenticated
result <- go now contentTypes body
recordActivity now result contentTypes body
case result of
Left _ -> sendResponseStatus badRequest400 ()
Right _ -> return ()
where
liftE = ExceptT . pure
handleWorkerError now ct d e = do
logError $ "postInboxR worker error: " <> T.pack (displayException e)
recordActivity now $ ActivityReportWorkerError ct (encodePretty d) e
recordActivity now item = do
go now ctypes (WithValue raw (Doc hActivity activity)) = runExceptT $ do
verifyContentType
HttpSigVerResult result <-
ExceptT $
first (T.pack . displayException) <$>
verifyRequestSignature now
ActorDetail uSender iid _raid <- ExceptT $ pure $ first T.pack result
let (hSender, luSender) = f2l uSender
unless (hSender == hActivity) $
throwE $ T.concat
[ "Activity host <", hActivity
, "> doesn't match signature key host <", hSender, ">"
]
unless (activityActor activity == luSender) $
throwE $ T.concat
[ "Activity's actor <"
, renderFedURI $ l2f hActivity $ activityActor activity
, "> != Signature key's actor <", renderFedURI uSender, ">"
]
handleSharerInbox now shrRecip iid raw activity
where
verifyContentType =
case ctypes of
[] -> throwE "Content-Type not specified"
[x] | x == typeAS -> return ()
| x == typeAS2 -> return ()
| otherwise ->
throwE $ "Not a recognized AP Content-Type: " <>
case decodeUtf8' x of
Left _ -> T.pack (show x)
Right t -> t
_ -> throwE "More than one Content-Type specified"
where
typeAS = "application/activity+json"
typeAS2 =
"application/ld+json; \
\profile=\"https://www.w3.org/ns/activitystreams\""
recordActivity now result contentTypes body = do
acts <- getsYesod appActivities
liftIO $ atomically $ modifyTVar' acts $ \ vec ->
let vec' = (now, item) `V.cons` vec
let msg = either id id result
formattedBody = encodePretty $ wvRaw body
item = ActivityReport now msg contentTypes formattedBody
vec' = item `V.cons` vec
in if V.length vec' > 10
then V.init vec'
else vec'
recordUsed now msg = recordActivity now $ ActivityReportUsed msg
recordUnused now ct d msg = recordActivity now $ ActivityReportUnused ct (encodePretty d) msg
recordError now e = recordActivity now $ ActivityReportHandlerError e
getActivity :: UTCTime -> ExceptT String Handler (ContentType, (WithValue (Doc Activity), (InstanceId, RemoteActorId)))
getActivity now = do
contentType <- do
ctypes <- lookupHeaders "Content-Type"
liftE $ case ctypes of
[] -> Left "Content-Type not specified"
[x] -> case x of
"application/activity+json" -> Right x
"application/ld+json; profile=\"https://www.w3.org/ns/activitystreams\"" -> Right x
_ -> Left "Unknown Content-Type"
_ -> Left "More than one Content-Type given"
HttpSigVerResult result <- ExceptT . fmap (first displayException) $ verifyRequestSignature now
(h, luActor) <- f2l . actorDetailId <$> liftE result
ActorDetail uActor iid rsid <- liftE result
let (h, luActor) = f2l uActor
wv@(WithValue _ (Doc h' a)) <- requireJsonBody
unless (h == h') $
throwE "Activity host doesn't match signature key host"
unless (activityActor a == luActor) $
throwE "Activity's actor != Signature key's actor"
return (contentType, (wv, (iid, rsid)))
postSharerInboxR :: ShrIdent -> Handler ()
postSharerInboxR _ = error "TODO implement postSharerInboxR"
postProjectInboxR :: ShrIdent -> PrjIdent -> Handler ()
postProjectInboxR _ _ = error "TODO implement postProjectInboxR"

View file

@ -245,6 +245,14 @@ changes =
"errorSince"
-- 59
, addEntities model_2019_04_12
-- 60
, addEntities model_2019_04_22
-- 61
, addFieldRefRequiredEmpty "RemoteMessage" "create" "RemoteActivity"
-- 62
, removeField "RemoteMessage" "raw"
-- 63
, removeEntity "RemoteRawObject"
]
migrateDB :: MonadIO m => ReaderT SqlBackend m (Either Text (Int, Int))

View file

@ -37,6 +37,7 @@ module Vervis.Migration.Model
, Ticket2019
, model_2019_04_11
, model_2019_04_12
, model_2019_04_22
)
where
@ -98,3 +99,6 @@ model_2019_04_11 = $(schema "2019_04_11")
model_2019_04_12 :: [Entity SqlBackend]
model_2019_04_12 = $(schema "2019_04_12")
model_2019_04_22 :: [Entity SqlBackend]
model_2019_04_22 = $(schema "2019_04_22")