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

@@ -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

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

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
+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
+    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

src/Vervis/Foundation.hs

@@ -85,11 +85,12 @@ import Vervis.Model.Role
 import Vervis.RemoteActorStore
 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
 -- 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

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.
             <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><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 ()
+postSharerInboxR :: ShrIdent -> Handler ()
-postInboxR = do
+postSharerInboxR shrRecip = do
     federation <- getsYesod $ appFederation . appSettings
     unless federation badMethod
+    contentTypes <- lookupHeaders "Content-Type"
+    body <- requireJsonBody
     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
-    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
         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"

src/Vervis/Migration.hs

@@ -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))

src/Vervis/Migration/Model.hs

@@ -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")