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 -- with this software. If not, see
-- <http://creativecommons.org/publicdomain/zero/1.0/>. -- <http://creativecommons.org/publicdomain/zero/1.0/>.
RemoteRawObject
content PersistJSONObject
received UTCTime
------------------------------------------------------------------------------- -------------------------------------------------------------------------------
-- People -- People
------------------------------------------------------------------------------- -------------------------------------------------------------------------------
@ -54,6 +50,20 @@ InboxItemLocal
UniqueInboxItemLocal person activity UniqueInboxItemLocal person activity
RemoteActivity
instance InstanceId
ident LocalURI
content PersistJSONObject
received UTCTime
UniqueRemoteActivity instance ident
InboxItemRemote
person PersonId
activity RemoteActivityId
UniqueInboxItemRemote person activity
UnlinkedDelivery UnlinkedDelivery
recipient UnfetchedRemoteActorId recipient UnfetchedRemoteActorId
activity OutboxItemId activity OutboxItemId
@ -299,7 +309,7 @@ RemoteMessage
instance InstanceId instance InstanceId
ident LocalURI ident LocalURI
rest MessageId rest MessageId
raw RemoteRawObjectId create RemoteActivityId
lostParent FedURI Maybe lostParent FedURI Maybe
UniqueRemoteMessageIdent instance ident 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 module Vervis.Federation
( handleInboxActivity ( handleSharerInbox
, fixRunningDeliveries , fixRunningDeliveries
, handleOutboxNote , handleOutboxNote
, retryOutboxDelivery , retryOutboxDelivery
@ -79,6 +79,7 @@ import Data.List.Local
import Data.List.NonEmpty.Local import Data.List.NonEmpty.Local
import Data.Maybe.Local import Data.Maybe.Local
import Database.Persist.Local import Database.Persist.Local
import Yesod.Persist.Local
import Vervis.ActorKey import Vervis.ActorKey
import Vervis.Foundation import Vervis.Foundation
@ -171,29 +172,120 @@ getLocalParentMessageId did shr lmid = do
throwE "Local parent belongs to a different discussion" throwE "Local parent belongs to a different discussion"
return mid return mid
-- | Handle an activity that came to our inbox. Return a description of what we handleSharerInbox
-- did, and whether we stored the activity or not (so that we can decide :: UTCTime
-- whether to log it for debugging). -> ShrIdent
handleInboxActivity :: Object -> Text -> InstanceId -> RemoteActorId -> Activity -> Handler (Text, Bool) -> InstanceId
handleInboxActivity raw hActor iidActor rsidActor (Activity _id _luActor audience specific) = -> Object
case specific of -> Activity
CreateActivity (Create note) -> do -> ExceptT Text Handler Text
result <- runExceptT $ handleCreate iidActor hActor rsidActor raw audience note handleSharerInbox now shrRecip iidSender raw activity =
case result of case activitySpecific activity of
Left e -> logWarn e >> return ("Create Note: " <> e, False) CreateActivity (Create note) -> handleNote note
Right (uNew, luTicket) -> _ -> return "Unsupported activity type"
return
( T.concat
[ "Inserted remote comment <"
, renderFedURI uNew
, "> into discussion of local ticket <"
, luriPath luTicket
, ">."
]
, True
)
_ -> return ("Unsupported activity type", False)
where 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 verifyLocal fu t = do
let (h, lu) = f2l fu let (h, lu) = f2l fu
local <- hostIsLocal h local <- hostIsLocal h
@ -217,19 +309,6 @@ handleInboxActivity raw hActor iidActor rsidActor (Activity _id _luActor audienc
m E.^. MessageRoot `op` E.val did m E.^. MessageRoot `op` E.val did
return (rm E.^. RemoteMessageId, m E.^. MessageId) return (rm E.^. RemoteMessageId, m E.^. MessageId)
handleCreate iidActor hActor rsidActor raw audience (Note mluNote _luAttrib _aud muParent muContext mpublished content) = do 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 ExceptT $ runDB $ runExceptT $ do
mrmid <- lift $ getKeyBy $ UniqueRemoteMessageIdent iidActor luNote mrmid <- lift $ getKeyBy $ UniqueRemoteMessageIdent iidActor luNote
for_ mrmid $ \ rmid -> for_ mrmid $ \ rmid ->
@ -307,6 +386,7 @@ handleInboxActivity raw hActor iidActor rsidActor (Activity _id _luActor audienc
, " because they have different DiscussionId!" , " because they have different DiscussionId!"
] ]
return (uNote, luContext) return (uNote, luContext)
-}
fixRunningDeliveries :: (MonadIO m, MonadLogger m, IsSqlBackend backend) => ReaderT backend m () fixRunningDeliveries :: (MonadIO m, MonadLogger m, IsSqlBackend backend) => ReaderT backend m ()
fixRunningDeliveries = do fixRunningDeliveries = do

View file

@ -85,11 +85,12 @@ import Vervis.Model.Role
import Vervis.RemoteActorStore import Vervis.RemoteActorStore
import Vervis.Widget (breadcrumbsW, revisionW) import Vervis.Widget (breadcrumbsW, revisionW)
data ActivityReport data ActivityReport = ActivityReport
= ActivityReportHandlerError String { _arTime :: UTCTime
| ActivityReportWorkerError ByteString BL.ByteString SomeException , _arMessage :: Text
| ActivityReportUsed Text , _arContentTypes :: [ContentType]
| ActivityReportUnused ByteString BL.ByteString Text , _arBody :: BL.ByteString
}
-- | The foundation datatype for your application. This can be a good place to -- | The foundation datatype for your application. This can be a good place to
-- keep settings and values requiring initialization before your application -- keep settings and values requiring initialization before your application
@ -109,7 +110,7 @@ data App = App
, appHashidsContext :: HashidsContext , appHashidsContext :: HashidsContext
, appActorFetchShare :: ActorFetchShare App , 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 -- 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.Bifunctor (first, second)
import Data.Foldable (for_) import Data.Foldable (for_)
import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict (HashMap)
import Data.List
import Data.List.NonEmpty (NonEmpty (..)) import Data.List.NonEmpty (NonEmpty (..))
import Data.Maybe import Data.Maybe
import Data.PEM (PEM (..)) import Data.PEM (PEM (..))
import Data.Text (Text) import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8) import Data.Text.Encoding (encodeUtf8, decodeUtf8')
import Data.Text.Lazy.Encoding (decodeUtf8) import Data.Text.Lazy.Encoding (decodeUtf8)
import Data.Time.Clock (UTCTime, getCurrentTime) import Data.Time.Clock (UTCTime, getCurrentTime)
import Data.Time.Interval (TimeInterval, toTimeUnit) 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.Client (Manager, HttpException, requestFromURI)
import Network.HTTP.Simple (httpJSONEither, getResponseBody, setRequestManager, addRequestHeader) import Network.HTTP.Simple (httpJSONEither, getResponseBody, setRequestManager, addRequestHeader)
import Network.HTTP.Types.Header (hDate, hHost) import Network.HTTP.Types.Header (hDate, hHost)
import Network.HTTP.Types.Status
import Text.Blaze.Html (Html) import Text.Blaze.Html (Html)
import Text.Shakespeare.I18N (RenderMessage) import Text.Shakespeare.I18N (RenderMessage)
import UnliftIO.Exception (try) import UnliftIO.Exception (try)
@ -84,7 +86,7 @@ import Yesod.HttpSignature (verifyRequestSignature)
import qualified Network.HTTP.Signature as S (Algorithm (..)) import qualified Network.HTTP.Signature as S (Algorithm (..))
import Data.Aeson.Encode.Pretty.ToEncoding import Data.Aeson.Encode.Pretty
import Data.Aeson.Local import Data.Aeson.Local
import Database.Persist.Local import Database.Persist.Local
import Network.FedURI import Network.FedURI
@ -117,23 +119,12 @@ getInboxR = do
with a report of what exactly happened. with a report of what exactly happened.
<p>Last 10 activities posted: <p>Last 10 activities posted:
<ul> <ul>
$forall (time, report) <- acts $forall ActivityReport time msg ctypes body <- acts
<li> <li>
<div>#{show time} <div>#{show time}
$case report <div>#{msg}
$of ActivityReportHandlerError e <div><code>#{intercalate " | " $ map BC.unpack ctypes}
<div>Handler error: <div><pre>#{decodeUtf8 body}
<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}
|] |]
getSharerInboxR :: ShrIdent -> Handler TypedContent getSharerInboxR :: ShrIdent -> Handler TypedContent
@ -142,61 +133,66 @@ getSharerInboxR _ = error "TODO implement getSharerInboxR"
getProjectInboxR :: ShrIdent -> PrjIdent -> Handler TypedContent getProjectInboxR :: ShrIdent -> PrjIdent -> Handler TypedContent
getProjectInboxR _ _ = error "TODO implement getProjectInboxR" getProjectInboxR _ _ = error "TODO implement getProjectInboxR"
postInboxR :: Handler () postSharerInboxR :: ShrIdent -> Handler ()
postInboxR = do postSharerInboxR shrRecip = do
federation <- getsYesod $ appFederation . appSettings federation <- getsYesod $ appFederation . appSettings
unless federation badMethod unless federation badMethod
contentTypes <- lookupHeaders "Content-Type"
body <- requireJsonBody
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
r <- runExceptT $ getActivity now result <- go now contentTypes body
case r of recordActivity now result contentTypes body
Right (ct, (WithValue raw d@(Doc h a), (iid, rsid))) -> case result of
forkHandler (handleWorkerError now ct d) $ do Left _ -> sendResponseStatus badRequest400 ()
(msg, stored) <- handleInboxActivity raw h iid rsid a Right _ -> return ()
if stored
then recordUsed now msg
else recordUnused now ct d msg
Left e -> do
recordError now e
notAuthenticated
where where
liftE = ExceptT . pure go now ctypes (WithValue raw (Doc hActivity activity)) = runExceptT $ do
handleWorkerError now ct d e = do verifyContentType
logError $ "postInboxR worker error: " <> T.pack (displayException e) HttpSigVerResult result <-
recordActivity now $ ActivityReportWorkerError ct (encodePretty d) e ExceptT $
recordActivity now item = do 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 acts <- getsYesod appActivities
liftIO $ atomically $ modifyTVar' acts $ \ vec -> 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 in if V.length vec' > 10
then V.init vec' then V.init vec'
else 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 :: ShrIdent -> PrjIdent -> Handler ()
postProjectInboxR _ _ = error "TODO implement postProjectInboxR" postProjectInboxR _ _ = error "TODO implement postProjectInboxR"

View file

@ -245,6 +245,14 @@ changes =
"errorSince" "errorSince"
-- 59 -- 59
, addEntities model_2019_04_12 , 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)) migrateDB :: MonadIO m => ReaderT SqlBackend m (Either Text (Int, Int))

View file

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