From f462a67680d580f7972150ba2f294710659f03d8 Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Tue, 23 Apr 2019 02:57:53 +0000 Subject: [PATCH] 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. --- config/models | 20 +++-- migrations/2019_04_22.model | 13 +++ src/Vervis/Federation.hs | 152 ++++++++++++++++++++++++++-------- src/Vervis/Foundation.hs | 13 +-- src/Vervis/Handler/Inbox.hs | 122 +++++++++++++-------------- src/Vervis/Migration.hs | 8 ++ src/Vervis/Migration/Model.hs | 4 + 7 files changed, 222 insertions(+), 110 deletions(-) create mode 100644 migrations/2019_04_22.model diff --git a/config/models b/config/models index 193de09..c286285 100644 --- a/config/models +++ b/config/models @@ -12,10 +12,6 @@ -- with this software. If not, see -- . -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 diff --git a/migrations/2019_04_22.model b/migrations/2019_04_22.model new file mode 100644 index 0000000..a5d92ec --- /dev/null +++ b/migrations/2019_04_22.model @@ -0,0 +1,13 @@ +RemoteActivity + instance InstanceId + ident Text + content PersistJSONValue + received UTCTime + + UniqueRemoteActivity instance ident + +InboxItemRemote + person PersonId + activity RemoteActivityId + + UniqueInboxItemRemote person activity diff --git a/src/Vervis/Federation.hs b/src/Vervis/Federation.hs index 217674d..cc1af18 100644 --- a/src/Vervis/Federation.hs +++ b/src/Vervis/Federation.hs @@ -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 diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index f59d5b1..77c65c0 100644 --- a/src/Vervis/Foundation.hs +++ b/src/Vervis/Foundation.hs @@ -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 diff --git a/src/Vervis/Handler/Inbox.hs b/src/Vervis/Handler/Inbox.hs index 74378bb..760ef5e 100644 --- a/src/Vervis/Handler/Inbox.hs +++ b/src/Vervis/Handler/Inbox.hs @@ -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.

Last 10 activities posted: