Decouple OutboxItem from Person via a new table named Outbox

config/models

@@ -35,14 +35,18 @@ Person
     resetPassKeyCreated UTCTime
     about               Text
     inbox               InboxId
+    outbox              OutboxId
 
     UniquePersonIdent ident
     UniquePersonLogin login
     UniquePersonEmail email
     UniquePersonInbox inbox
+    UniquePersonOutbox outbox
+
+Outbox
 
 OutboxItem
-    person    PersonId
+    outbox    OutboxId
     activity  PersistActivity
     published UTCTime
 

migrations/2019_06_15.model

@@ -0,0 +1,26 @@
+Person
+    ident               Int64
+    login               Text
+    passphraseHash      ByteString
+    email               Text
+    verified            Bool
+    verifiedKey         Text
+    verifiedKeyCreated  UTCTime
+    resetPassKey        Text
+    resetPassKeyCreated UTCTime
+    about               Text
+    inbox               Int64
+    outbox              OutboxId
+
+    UniquePersonIdent ident
+    UniquePersonLogin login
+    UniquePersonEmail email
+    UniquePersonInbox inbox
+
+Outbox
+
+OutboxItem
+    person    PersonId
+    outbox    OutboxId
+    activity  PersistJSONObject
+    published UTCTime

src/Vervis/API.hs

@@ -162,8 +162,8 @@ createNoteC host (Note mluNote luAttrib aud muParent muContext mpublished source
     federation <- getsYesod $ appFederation . appSettings
     unless (federation || null remoteRecips) $
         throwE "Federation disabled, but remote recipients specified"
-    (lmid, obid, doc, remotesHttp) <- runDBExcept $ do
+    (lmid, obiid, doc, remotesHttp) <- runDBExcept $ do
-        (pid, shrUser) <- verifyIsLoggedInUser luAttrib "Note attributed to different actor"
+        (pid, obid, shrUser) <- verifyIsLoggedInUser luAttrib "Note attributed to different actor"
         (did, meparent, mcollections) <- case mticket of
             Just (shr, prj, num) -> do
                 mt <- lift $ runMaybeT $ do
@@ -231,13 +231,13 @@ createNoteC host (Note mluNote luAttrib aud muParent muContext mpublished source
                       \ commented on a #
                       <a href=#{renderFedURI uContext}>ticket</a>.
                 |]
-        (lmid, obid, doc) <- lift $ insertMessage luAttrib shrUser pid uContext did muParent meparent source content summary
+        (lmid, obiid, doc) <- lift $ insertMessage luAttrib shrUser pid obid uContext did muParent meparent source content summary
-        moreRemotes <- deliverLocal pid obid localRecips mcollections
+        moreRemotes <- deliverLocal pid obiid localRecips mcollections
         unless (federation || null moreRemotes) $
             throwE "Federation disabled but remote collection members found"
-        remotesHttp <- lift $ deliverRemoteDB (furiHost uContext) obid remoteRecips moreRemotes
+        remotesHttp <- lift $ deliverRemoteDB (furiHost uContext) obiid remoteRecips moreRemotes
-        return (lmid, obid, doc, remotesHttp)
+        return (lmid, obiid, doc, remotesHttp)
-    lift $ forkWorker "Outbox POST handler: async HTTP delivery" $ deliverRemoteHttp (furiHost uContext) obid doc remotesHttp
+    lift $ forkWorker "Outbox POST handler: async HTTP delivery" $ deliverRemoteHttp (furiHost uContext) obiid doc remotesHttp
     return lmid
     where
     nonEmptyE :: Monad m => [a] -> e -> ExceptT e m (NonEmpty a)
@@ -401,20 +401,24 @@ createNoteC host (Note mluNote luAttrib aud muParent muContext mpublished source
         verifyOnlySharers :: LocalRecipientSet -> ExceptT Text Handler [ShrIdent]
         verifyOnlySharers lrs = catMaybes <$> traverse (atMostSharer "Note with remote context but local project-related recipients") lrs
 
-    verifyIsLoggedInUser :: LocalURI -> Text -> ExceptT Text AppDB (PersonId, ShrIdent)
+    verifyIsLoggedInUser
+        :: LocalURI
+        -> Text
+        -> ExceptT Text AppDB (PersonId, OutboxId, 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)
+            then return (pid, personOutbox p, shr)
             else throwE t
 
     insertMessage
         :: LocalURI
         -> ShrIdent
         -> PersonId
+        -> OutboxId
         -> FedURI
         -> DiscussionId
         -> Maybe FedURI
@@ -423,7 +427,7 @@ createNoteC host (Note mluNote luAttrib aud muParent muContext mpublished source
         -> Text
         -> Html
         -> AppDB (LocalMessageId, OutboxItemId, Doc Activity)
-    insertMessage luAttrib shrUser pid uContext did muParent meparent source content summary = do
+    insertMessage luAttrib shrUser pid obid uContext did muParent meparent source content summary = do
         now <- liftIO getCurrentTime
         mid <- insert Message
             { messageCreated = now
@@ -454,28 +458,28 @@ createNoteC host (Note mluNote luAttrib aud muParent muContext mpublished source
                     }
                 }
             tempUri = LocalURI "" ""
-        obid <- insert OutboxItem
+        obiid <- insert OutboxItem
-            { outboxItemPerson    = pid
+            { outboxItemOutbox    = obid
             , outboxItemActivity  = PersistJSON $ activity tempUri tempUri
             , outboxItemPublished = now
             }
         lmid <- insert LocalMessage
             { localMessageAuthor         = pid
             , localMessageRest           = mid
-            , localMessageCreate         = obid
+            , localMessageCreate         = obiid
             , localMessageUnlinkedParent =
                 case meparent of
                     Just (Right uParent) -> Just uParent
                     _                    -> Nothing
             }
         route2local <- getEncodeRouteLocal
-        obhid <- encodeKeyHashid obid
+        obihid <- encodeKeyHashid obiid
         lmhid <- encodeKeyHashid lmid
-        let luAct = route2local $ OutboxItemR shrUser obhid
+        let luAct = route2local $ OutboxItemR shrUser obihid
             luNote = route2local $ MessageR shrUser lmhid
             doc = activity luAct luNote
-        update obid [OutboxItemActivity =. PersistJSON doc]
+        update obiid [OutboxItemActivity =. PersistJSON doc]
-        return (lmid, obid, doc)
+        return (lmid, obiid, doc)
 
     -- Deliver to local recipients. For local users, find in DB and deliver.
     -- For local collections, expand them, deliver to local users, and return a

src/Vervis/Federation.hs

@@ -410,22 +410,25 @@ handleSharerInbox
     -> Activity
     -> ExceptT Text Handler Text
 handleSharerInbox _now shrRecip (Left pidAuthor) _raw activity = do
-    (shrActivity, obid) <- do
+    (shrActivity, obiid) <- do
         route <-
             case decodeRouteLocal $ activityId activity of
                 Nothing -> throwE "Local activity: Not a valid route"
                 Just r -> return r
         case route of
-            OutboxItemR shr obkhid ->
+            OutboxItemR shr obikhid ->
-                (shr,) <$> decodeKeyHashidE obkhid "Local activity: ID is invalid hashid"
+                (shr,) <$> decodeKeyHashidE obikhid "Local activity: ID is invalid hashid"
             _ -> throwE "Local activity: Not an activity route"
     runDBExcept $ do
         Entity pidRecip personRecip <- lift $ do
             sid <- getKeyBy404 $ UniqueSharer shrRecip
             getBy404 $ UniquePersonIdent sid
-        mob <- lift $ get obid
+        mobi <- lift $ get obiid
-        ob <- fromMaybeE mob "Local activity: No such ID in DB"
+        obi <- fromMaybeE mobi "Local activity: No such ID in DB"
-        let pidOutbox = outboxItemPerson ob
+        mpidOutbox <-
+            lift $ getKeyBy $ UniquePersonOutbox $ outboxItemOutbox obi
+        pidOutbox <-
+            fromMaybeE mpidOutbox "Local activity not in a user outbox"
         p <- lift $ getJust pidOutbox
         s <- lift $ getJust $ personIdent p
         unless (sharerIdent s == shrActivity) $
@@ -437,7 +440,7 @@ handleSharerInbox _now shrRecip (Left pidAuthor) _raw activity = do
             else lift $ do
                 ibiid <- insert $ InboxItem True
                 let ibid = personInbox personRecip
-                miblid <- insertUnique $ InboxItemLocal ibid obid ibiid
+                miblid <- insertUnique $ InboxItemLocal ibid obiid ibiid
                 let recip = shr2text shrRecip
                 case miblid of
                     Nothing -> do

src/Vervis/Foundation.hs

@@ -589,6 +589,7 @@ instance AccountDB AccountPersistDB' where
                 return $ Left $ mr $ MsgUsernameExists name
             Right sid -> do
                 ibid <- insert Inbox
+                obid <- insert Outbox
                 let defTime = UTCTime (ModifiedJulianDay 0) 0
                     person = Person
                         { personIdent               = sid
@@ -602,6 +603,7 @@ instance AccountDB AccountPersistDB' where
                         , personResetPassKeyCreated = defTime
                         , personAbout               = ""
                         , personInbox               = ibid
+                        , personOutbox              = obid
                         }
                 pid <- insert person
                 return $ Right $ Entity pid person

src/Vervis/Handler/Inbox.hs

@@ -369,9 +369,10 @@ getOutboxR :: ShrIdent -> Handler TypedContent
 getOutboxR shr = do
     (total, pages, mpage) <- runDB $ do
         sid <- getKeyBy404 $ UniqueSharer shr
-        pid <- getKeyBy404 $ UniquePersonIdent sid
+        p <- getValBy404 $ UniquePersonIdent sid
-        let countAllItems = count [OutboxItemPerson ==. pid]
+        let obid = personOutbox p
-            selectItems off lim = selectList [OutboxItemPerson ==. pid] [Desc OutboxItemId, OffsetBy off, LimitTo lim]
+            countAllItems = count [OutboxItemOutbox ==. obid]
+            selectItems off lim = selectList [OutboxItemOutbox ==. obid] [Desc OutboxItemId, OffsetBy off, LimitTo lim]
         getPageAndNavCount countAllItems selectItems
     let here = OutboxR shr
     encodeRouteLocal <- getEncodeRouteLocal
@@ -423,14 +424,14 @@ getOutboxR shr = do
                     defaultLayout $(widgetFile "person/outbox")
 
 getOutboxItemR :: ShrIdent -> KeyHashid OutboxItem -> Handler TypedContent
-getOutboxItemR shr obkhid = do
+getOutboxItemR shr obikhid = do
-    obid <- decodeKeyHashid404 obkhid
+    obiid <- decodeKeyHashid404 obikhid
     doc <- runDB $ do
         sid <- getKeyBy404 $ UniqueSharer shr
-        pid <- getKeyBy404 $ UniquePersonIdent sid
+        p <- getValBy404 $ UniquePersonIdent sid
-        ob <- get404 obid
+        obi <- get404 obiid
-        unless (outboxItemPerson ob == pid) notFound
+        unless (outboxItemOutbox obi == personOutbox p) notFound
-        return $ persistJSONValue $ outboxItemActivity ob
+        return $ persistJSONValue $ outboxItemActivity obi
     selectRep $ do
         provideAP $ pure doc
         provideRep $ defaultLayout $

src/Vervis/Migration.hs

@@ -788,6 +788,37 @@ changes hLocal ctx =
       -- 115
     , addUnique "TicketAuthorLocal" $
         Unique "UniqueTicketAuthorLocaleOffer" ["offer"]
+      -- 116
+    , addEntity $ ST.Entity "Outbox" [] []
+      -- 117
+    , addFieldRefRequired'
+        "Person"
+        Outbox20190615
+        (Just $ do
+            pids <- selectKeysList ([] :: [Filter Person20190615]) []
+            for_ pids $ \ pid -> do
+                obid <- insert Outbox20190615
+                update pid [Person20190615Outbox =. obid]
+        )
+        "outbox"
+        "Outbox"
+      -- 118
+    , addUnique "Person" $ Unique "UniquePersonOutbox" ["outbox"]
+      -- 119
+    , addFieldRefRequired'
+        "OutboxItem"
+        Outbox20190615
+        (Just $ do
+            obiids <- selectList ([] :: [Filter OutboxItem20190615]) []
+            for_ obiids $ \ (Entity obiid obi) -> do
+                person <- getJust $ outboxItem20190615Person obi
+                let obid = person20190615Outbox person
+                update obiid [OutboxItem20190615Outbox =. obid]
+        )
+        "outbox"
+        "Outbox"
+      -- 120
+    , removeField "OutboxItem" "person"
     ]
 
 migrateDB

src/Vervis/Migration/Model.hs

@@ -91,6 +91,11 @@ module Vervis.Migration.Model
     , Ticket20190612Generic (..)
     , Ticket20190612
     , TicketAuthorLocal20190612Generic (..)
+    , Person20190615Generic (..)
+    , Person20190615
+    , Outbox20190615Generic (..)
+    , OutboxItem20190615Generic (..)
+    , OutboxItem20190615
     )
 where
 
@@ -199,3 +204,6 @@ makeEntitiesMigration "20190610"
 
 makeEntitiesMigration "20190612"
     $(modelFile "migrations/2019_06_12.model")
+
+makeEntitiesMigration "20190615"
+    $(modelFile "migrations/2019_06_15.model")