diff --git a/config/models b/config/models index 0544d83..282f6b5 100644 --- a/config/models +++ b/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 diff --git a/migrations/2019_06_15.model b/migrations/2019_06_15.model new file mode 100644 index 0000000..4848029 --- /dev/null +++ b/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 diff --git a/src/Vervis/API.hs b/src/Vervis/API.hs index 1c6333f..c7ebd75 100644 --- a/src/Vervis/API.hs +++ b/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 - (pid, shrUser) <- verifyIsLoggedInUser luAttrib "Note attributed to different actor" + (lmid, obiid, doc, remotesHttp) <- runDBExcept $ do + (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 # ticket. |] - (lmid, obid, doc) <- lift $ insertMessage luAttrib shrUser pid uContext did muParent meparent source content summary - moreRemotes <- deliverLocal pid obid localRecips mcollections + (lmid, obiid, doc) <- lift $ insertMessage luAttrib shrUser pid obid uContext did muParent meparent source content summary + 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 - return (lmid, obid, doc, remotesHttp) - lift $ forkWorker "Outbox POST handler: async HTTP delivery" $ deliverRemoteHttp (furiHost uContext) obid doc remotesHttp + remotesHttp <- lift $ deliverRemoteDB (furiHost uContext) obiid remoteRecips moreRemotes + return (lmid, obiid, 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 - { outboxItemPerson = pid + obiid <- insert OutboxItem + { 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] - return (lmid, obid, doc) + update obiid [OutboxItemActivity =. PersistJSON 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 diff --git a/src/Vervis/Federation.hs b/src/Vervis/Federation.hs index 32f19c0..39f91a8 100644 --- a/src/Vervis/Federation.hs +++ b/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 -> - (shr,) <$> decodeKeyHashidE obkhid "Local activity: ID is invalid hashid" + OutboxItemR shr obikhid -> + (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 - ob <- fromMaybeE mob "Local activity: No such ID in DB" - let pidOutbox = outboxItemPerson ob + mobi <- lift $ get obiid + obi <- fromMaybeE mobi "Local activity: No such ID in DB" + 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 diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index d1857cc..26d573e 100644 --- a/src/Vervis/Foundation.hs +++ b/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 diff --git a/src/Vervis/Handler/Inbox.hs b/src/Vervis/Handler/Inbox.hs index 220f953..be84f5d 100644 --- a/src/Vervis/Handler/Inbox.hs +++ b/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 - let countAllItems = count [OutboxItemPerson ==. pid] - selectItems off lim = selectList [OutboxItemPerson ==. pid] [Desc OutboxItemId, OffsetBy off, LimitTo lim] + p <- getValBy404 $ UniquePersonIdent sid + let obid = personOutbox p + 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 - obid <- decodeKeyHashid404 obkhid +getOutboxItemR shr obikhid = do + obiid <- decodeKeyHashid404 obikhid doc <- runDB $ do sid <- getKeyBy404 $ UniqueSharer shr - pid <- getKeyBy404 $ UniquePersonIdent sid - ob <- get404 obid - unless (outboxItemPerson ob == pid) notFound - return $ persistJSONValue $ outboxItemActivity ob + p <- getValBy404 $ UniquePersonIdent sid + obi <- get404 obiid + unless (outboxItemOutbox obi == personOutbox p) notFound + return $ persistJSONValue $ outboxItemActivity obi selectRep $ do provideAP $ pure doc provideRep $ defaultLayout $ diff --git a/src/Vervis/Migration.hs b/src/Vervis/Migration.hs index 4fc936f..e974882 100644 --- a/src/Vervis/Migration.hs +++ b/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 diff --git a/src/Vervis/Migration/Model.hs b/src/Vervis/Migration/Model.hs index 12ba7ea..266fa76 100644 --- a/src/Vervis/Migration/Model.hs +++ b/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")