diff --git a/src/Vervis/API.hs b/src/Vervis/API.hs index 0d862d1..759144f 100644 --- a/src/Vervis/API.hs +++ b/src/Vervis/API.hs @@ -115,33 +115,6 @@ import Vervis.Settings import Vervis.Patch import Vervis.Ticket -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, personOutbox p, shr) - else throwE t - -verifyAuthor - :: ShrIdent - -> LocalURI - -> Text - -> ExceptT Text AppDB (PersonId, OutboxId) -verifyAuthor shr lu t = ExceptT $ do - Entity sid s <- getBy404 $ UniqueSharer shr - Entity pid p <- getBy404 $ UniquePersonIdent sid - encodeRouteLocal <- getEncodeRouteLocal - return $ - if encodeRouteLocal (SharerR shr) == lu - then Right (pid, personOutbox p) - else Left t - parseComment :: LocalURI -> ExceptT Text Handler (ShrIdent, LocalMessageId) parseComment luParent = do route <- case decodeRouteLocal luParent of @@ -508,6 +481,20 @@ createNoteC (Entity pidUser personUser) sharerUser summary audience note muTarge update obiidCreate [OutboxItemActivity =. persistJSONObjectFromDoc create] return create +checkFederation remoteRecips = do + federation <- asksSite $ appFederation . appSettings + unless (federation || null remoteRecips) $ + throwE "Federation disabled, but remote recipients found" + +verifyProjectRecip (Right _) _ = return () +verifyProjectRecip (Left (shr, prj)) localRecips = + fromMaybeE verify "Local context project isn't listed as a recipient" + where + verify = do + sharerSet <- lookup shr localRecips + projectSet <- lookup prj $ localRecipProjectRelated sharerSet + guard $ localRecipProject $ localRecipProjectDirect projectSet + -- | Handle a Ticket submitted by a local user to their outbox. The ticket's -- context project may be local or remote. Return an error message if the -- Ticket is rejected, otherwise the new 'TicketAuthorLocalId'. @@ -602,20 +589,6 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT _ -> throwE "Ticket context isn't a project route" else return $ Right u - checkFederation remoteRecips = do - federation <- asksSite $ appFederation . appSettings - unless (federation || null remoteRecips) $ - throwE "Federation disabled, but remote recipients found" - - verifyProjectRecip (Right _) _ = return () - verifyProjectRecip (Left (shr, prj)) localRecips = - fromMaybeE verify "Local context project isn't listed as a recipient" - where - verify = do - sharerSet <- lookup shr localRecips - projectSet <- lookup prj $ localRecipProjectRelated sharerSet - guard $ localRecipProject $ localRecipProjectDirect projectSet - fetchTracker c u@(ObjURI h lu) = do hl <- hostIsLocal h case (hl, c) of @@ -639,14 +612,6 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT return (iid, era) return (iid, era, if lu == lu' then Nothing else Just lu') - insertEmptyOutboxItem obid now = do - h <- asksSite siteInstanceHost - insert OutboxItem - { outboxItemOutbox = obid - , outboxItemActivity = persistJSONObjectFromDoc $ Doc h emptyActivity - , outboxItemPublished = now - } - prepareProject now (Left (shr, prj)) = Left <$> do mej <- lift $ runMaybeT $ do sid <- MaybeT $ getKeyBy $ UniqueSharer shr @@ -997,279 +962,198 @@ followC shrUser summary audience follow@(AP.Follow uObject muContext hide) = do insert_ $ InboxItemLocal ibidAuthor obiidAccept ibiid offerTicketC - :: ShrIdent + :: Entity Person + -> Sharer -> Maybe TextHtml -> Audience URIMode -> AP.Ticket URIMode -> FedURI -> ExceptT Text Handler OutboxItemId -offerTicketC shrUser summary audience ticket uTarget = do - (hProject, shrProject, prjProject) <- parseTarget uTarget - {-deps <- -} - checkOffer hProject shrProject prjProject +offerTicketC (Entity pidUser personUser) sharerUser summary audience ticket uTarget = do + let shrUser = sharerIdent sharerUser + (title, desc, source, target) <- checkTicket shrUser ticket uTarget (localRecips, remoteRecips) <- do mrecips <- parseAudience audience - fromMaybeE mrecips "Offer with no recipients" + fromMaybeE mrecips "Offer Ticket with no recipients" federation <- asksSite $ appFederation . appSettings unless (federation || null remoteRecips) $ throwE "Federation disabled, but remote recipients specified" - checkRecips hProject shrProject prjProject localRecips + verifyProjectRecip target localRecips now <- liftIO getCurrentTime - (obiid, doc, remotesHttp) <- runDBExcept $ do - (pidAuthor, obidAuthor) <- - verifyAuthor - shrUser - (AP.ticketAttributedTo ticket) - "Ticket attributed to different actor" - mprojAndDeps <- do - targetIsLocal <- hostIsLocal hProject - if targetIsLocal - then Just <$> getProjectAndDeps shrProject prjProject {-deps-} - else return Nothing - (obiid, doc, luOffer) <- lift $ insertToOutbox now obidAuthor - moreRemotes <- - lift $ deliverLocal pidAuthor shrProject prjProject now mprojAndDeps obiid luOffer localRecips - unless (federation || null moreRemotes) $ - throwE "Federation disabled but remote collection members found" - remotesHttp <- lift $ deliverRemoteDB' hProject obiid remoteRecips moreRemotes - return (obiid, doc, remotesHttp) - lift $ forkWorker "Outbox POST handler: async HTTP delivery" $ deliverRemoteHttp hProject obiid doc remotesHttp - return obiid + (obiidOffer, docOffer, remotesHttpOffer, maybeAccept) <- runDBExcept $ do + mproject <- + case target of + Left (shr, prj) -> Just <$> do + mproj <- lift $ runMaybeT $ do + Entity sid s <- MaybeT $ getBy $ UniqueSharer shr + ej <- MaybeT $ getBy $ UniqueProject prj sid + return (s, ej) + fromMaybeE mproj "Offer target no such local project in DB" + Right _ -> return Nothing + (obiid, doc, luOffer) <- lift $ insertOfferToOutbox shrUser now (personOutbox personUser) + remotesHttpOffer <- do + let sieve = + case target of + Left (shr, prj) -> + makeRecipientSet + [ LocalActorProject shr prj + ] + [ LocalPersonCollectionSharerFollowers shrUser + , LocalPersonCollectionProjectTeam shr prj + , LocalPersonCollectionProjectFollowers shr prj + ] + Right _ -> + makeRecipientSet + [] + [LocalPersonCollectionSharerFollowers shrUser] + moreRemoteRecips <- + lift $ + deliverLocal' + True + (LocalActorSharer shrUser) + (personInbox personUser) + obiid + (localRecipSieve sieve False localRecips) + unless (federation || null moreRemoteRecips) $ + throwE "Federation disabled, but recipient collection remote members found" + lift $ deliverRemoteDB' (objUriAuthority uTarget) obiid remoteRecips moreRemoteRecips + maccept <- lift $ for mproject $ \ (s, Entity jid j) -> do + let shrJ = sharerIdent s + prj = projectIdent j + obiidAccept <- insertEmptyOutboxItem (projectOutbox j) now + ltid <- insertTicket pidUser now title desc source jid obiid obiidAccept + (docAccept, localRecipsAccept) <- insertAccept shrUser luOffer shrJ prj obiidAccept ltid + knownRemoteRecipsAccept <- + deliverLocal' + False + (LocalActorProject shrJ prj) + (projectInbox j) + obiidAccept + localRecipsAccept + (obiidAccept,docAccept,) <$> deliverRemoteDB'' [] obiidAccept [] knownRemoteRecipsAccept + return (obiid, doc, remotesHttpOffer, maccept) + lift $ do + forkWorker "offerTicketC: async HTTP Offer delivery" $ deliverRemoteHttp (objUriAuthority uTarget) obiidOffer docOffer remotesHttpOffer + for_ maybeAccept $ \ (obiidAccept, docAccept, remotesHttpAccept) -> + forkWorker "offerTicketC: async HTTP Accept delivery" $ deliverRemoteHttp' [] obiidAccept docAccept remotesHttpAccept + return obiidOffer where - checkOffer hProject shrProject prjProject = do - verifyNothingE (AP.ticketLocal ticket) "Ticket with 'id'" - verifyNothingE (AP.ticketPublished ticket) "Ticket with 'published'" - verifyNothingE (AP.ticketUpdated ticket) "Ticket with 'updated'" - -- verifyNothingE (AP.ticketName ticket) "Ticket with 'name'" - verifyNothingE (AP.ticketAssignedTo ticket) "Ticket with 'assignedTo'" - when (AP.ticketIsResolved ticket) $ throwE "Ticket resolved" - checkRecips hProject shrProject prjProject localRecips = do - local <- hostIsLocal hProject - if local - then traverse (verifyOfferRecips shrProject prjProject) localRecips - else traverse (verifyOnlySharer . snd) localRecips + checkTicket + shrUser + (AP.Ticket mlocal attrib mpublished mupdated muContext summary + content source muAssigned resolved mmr) + uTarget = do + verifyNothingE mlocal "Ticket with 'id'" + shrAttrib <- do + route <- fromMaybeE (decodeRouteLocal attrib) "Ticket attrib not a valid route" + case route of + SharerR shr -> return shr + _ -> throwE "Ticket attrib not a sharer route" + unless (shrAttrib == shrUser) $ + throwE "Ticket attibuted to someone else" + verifyNothingE (AP.ticketPublished ticket) "Ticket with 'published'" + verifyNothingE (AP.ticketUpdated ticket) "Ticket with 'updated'" + for_ muContext $ \ uContext -> + unless (uContext == uTarget) $ throwE "Offer target != ticket context" + verifyNothingE muAssigned "Ticket has 'assignedTo'" + when resolved $ throwE "Ticket is resolved" + verifyNothingE mmr "Ticket has 'attachment'" + target <- parseTarget uTarget + return (summary, content, source, target) where - verifyOfferRecips shr prj (shr', lsrSet) = - if shr == shr' - then unless (lsrSet == offerRecips prj) $ - throwE "Unexpected offer target recipient set" - else verifyOnlySharer lsrSet - where - offerRecips prj = LocalSharerRelatedSet - { localRecipSharerDirect = LocalSharerDirectSet False False - , localRecipSharerTicketRelated = [] - , localRecipProjectRelated = - [ ( prj - , LocalProjectRelatedSet - { localRecipProjectDirect = - LocalProjectDirectSet True True True - , localRecipProjectTicketRelated = [] - } - ) - ] - , localRecipRepoRelated = [] - } - verifyOnlySharer lsrSet = do - unless (null $ localRecipProjectRelated lsrSet) $ - throwE "Unexpected recipients unrelated to offer target" - unless (null $ localRecipRepoRelated lsrSet) $ - throwE "Unexpected recipients unrelated to offer target" - insertToOutbox now obid = do + parseTarget u@(ObjURI h lu) = do + hl <- hostIsLocal h + if hl + then Left <$> do + route <- fromMaybeE (decodeRouteLocal lu) "Offer target is local but not a valid route" + case route of + ProjectR shr prj -> return (shr, prj) + RepoR _ _ -> throwE "Offering patch to repo not implemented yet" + _ -> throwE "Offer target is local but isn't a project/repo route" + else return $ Right u + insertOfferToOutbox shrUser now obid = do hLocal <- asksSite siteInstanceHost - let activity mluAct = Doc hLocal Activity - { activityId = mluAct - , activityActor = AP.ticketAttributedTo ticket - , activitySummary = Just summary + obiid <- insertEmptyOutboxItem obid now + encodeRouteLocal <- getEncodeRouteLocal + obikhid <- encodeKeyHashid obiid + let luAct = encodeRouteLocal $ SharerOutboxItemR shrUser obikhid + doc = Doc hLocal Activity + { activityId = Just luAct + , activityActor = encodeRouteLocal $ SharerR shrUser + , activitySummary = summary , activityAudience = audience , activitySpecific = OfferActivity $ Offer (OfferTicket ticket) uTarget } - obiid <- insert OutboxItem - { outboxItemOutbox = obid - , outboxItemActivity = - persistJSONObjectFromDoc $ activity Nothing - , outboxItemPublished = now - } - encodeRouteLocal <- getEncodeRouteLocal - obikhid <- encodeKeyHashid obiid - let luAct = encodeRouteLocal $ SharerOutboxItemR shrUser obikhid - doc = activity $ Just luAct update obiid [OutboxItemActivity =. persistJSONObjectFromDoc doc] return (obiid, doc, luAct) - deliverLocal pidAuthor shrProject prjProject now mprojAndDeps obiid luOffer recips = do - (pids, remotes) <- forCollect recips $ \ (shr, LocalSharerRelatedSet sharer _ _ projects _) -> do - (pids, remotes) <- - traverseCollect (uncurry $ deliverLocalProject shr) projects - pids' <- do - mpid <- - if localRecipSharer sharer - then runMaybeT $ do - sid <- MaybeT $ getKeyBy $ UniqueSharer shr - MaybeT $ getKeyBy $ UniquePersonIdent sid - else return Nothing - return $ - case mpid of - Nothing -> pids - Just pid -> LO.insertSet pid pids - return (pids', remotes) - for_ (L.delete pidAuthor pids) $ \ pid -> do - ibid <- personInbox <$> getJust pid - ibiid <- insert $ InboxItem True - insert_ $ InboxItemLocal ibid obiid ibiid - return remotes - where - traverseCollect action values = - bimap collectPids collectRemotes . unzip <$> traverse action values - where - collectPids = foldl' LO.union [] - collectRemotes = foldl' unionRemotes [] - forCollect = flip traverseCollect - deliverLocalProject shr prj (LocalProjectRelatedSet project _) = - case mprojAndDeps of - Just (sid, jid, ibid, fsid{-, tids-}) - | shr == shrProject && - prj == prjProject && - localRecipProject project -> do - insertToInbox ibid - {- - num <- - ((subtract 1) . projectNextTicket) <$> - updateGet jid [ProjectNextTicket +=. 1] - -} - obiidAccept <- do - obidProject <- projectOutbox <$> getJust jid - now <- liftIO getCurrentTime - hLocal <- asksSite siteInstanceHost - insert OutboxItem - { outboxItemOutbox = obidProject - , outboxItemActivity = - persistJSONObjectFromDoc $ Doc hLocal emptyActivity - , outboxItemPublished = now - } - ltid <- insertTicket jid {-tids-} {-num-} obiidAccept - docAccept <- insertAccept pidAuthor sid jid fsid luOffer obiidAccept ltid - publishAccept pidAuthor sid jid fsid luOffer {-num-} obiidAccept docAccept - (pidsTeam, remotesTeam) <- - if localRecipProjectTeam project - then getProjectTeam sid - else return ([], []) - (pidsFollowers, remotesFollowers) <- - if localRecipProjectFollowers project - then getFollowers fsid - else return ([], []) - return - ( LO.union pidsTeam pidsFollowers - , unionRemotes remotesTeam remotesFollowers - ) - _ -> return ([], []) - where - insertToInbox ibid = do - ibiid <- insert $ InboxItem False - insert_ $ InboxItemLocal ibid obiid ibiid - insertAccept pidAuthor sid jid fsid luOffer obiid ltid = do - ltkhid <- encodeKeyHashid ltid - summary <- - TextHtml . TL.toStrict . renderHtml <$> - withUrlRenderer - [hamlet| -

- - #{shr2text shrUser} - 's ticket accepted by project # - - ./s/#{shr2text shrProject}/p/#{prj2text prjProject} - : # - - #{preEscapedToHtml $ unTextHtml $ AP.ticketSummary ticket}. - |] - hLocal <- asksSite siteInstanceHost - encodeRouteLocal <- getEncodeRouteLocal - encodeRouteHome <- getEncodeRouteHome - obikhid <- encodeKeyHashid obiid - let recips = - map encodeRouteHome - [ SharerR shrUser - , ProjectTeamR shrProject prjProject - , ProjectFollowersR shrProject prjProject - ] - doc = Doc hLocal Activity - { activityId = - Just $ encodeRouteLocal $ - ProjectOutboxItemR shrProject prjProject obikhid - , activityActor = - encodeRouteLocal $ ProjectR shrProject prjProject - , activitySummary = Just summary - , activityAudience = Audience recips [] [] [] [] [] - , activitySpecific = AcceptActivity Accept - { acceptObject = ObjURI hLocal luOffer - , acceptResult = - Just $ encodeRouteLocal $ - ProjectTicketR shrProject prjProject ltkhid - } - } - update - obiid - [OutboxItemActivity =. persistJSONObjectFromDoc doc] - return doc - insertTicket jid {-tidsDeps-} {-next-} obiidAccept = do - did <- insert Discussion - fsid <- insert FollowerSet - tid <- insert Ticket - { ticketNumber = Nothing - , ticketCreated = now - , ticketTitle = unTextHtml $ AP.ticketSummary ticket - , ticketSource = - unTextPandocMarkdown $ AP.ticketSource ticket - , ticketDescription = unTextHtml $ AP.ticketContent ticket - , ticketAssignee = Nothing - , ticketStatus = TSNew - , ticketClosed = UTCTime (ModifiedJulianDay 0) 0 - , ticketCloser = Nothing + insertTicket pidAuthor now title desc source jid obiid obiidAccept = do + did <- insert Discussion + fsid <- insert FollowerSet + tid <- insert Ticket + { ticketNumber = Nothing + , ticketCreated = now + , ticketTitle = unTextHtml title + , ticketSource = unTextPandocMarkdown source + , ticketDescription = unTextHtml desc + , ticketAssignee = Nothing + , ticketStatus = TSNew + , ticketClosed = UTCTime (ModifiedJulianDay 0) 0 + , ticketCloser = Nothing + } + ltid <- insert LocalTicket + { localTicketTicket = tid + , localTicketDiscuss = did + , localTicketFollowers = fsid + } + tclid <- insert TicketContextLocal + { ticketContextLocalTicket = tid + , ticketContextLocalAccept = obiidAccept + } + insert_ TicketProjectLocal + { ticketProjectLocalContext = tclid + , ticketProjectLocalProject = jid + } + talid <- insert TicketAuthorLocal + { ticketAuthorLocalTicket = ltid + , ticketAuthorLocalAuthor = pidAuthor + , ticketAuthorLocalOpen = obiid + } + insert_ TicketUnderProject + { ticketUnderProjectProject = tclid + , ticketUnderProjectAuthor = talid + } + return ltid + insertAccept shrUser luOffer shrJ prj obiidAccept ltid = do + encodeRouteLocal <- getEncodeRouteLocal + encodeRouteHome <- getEncodeRouteHome + hLocal <- asksSite siteInstanceHost + obikhidAccept <- encodeKeyHashid obiidAccept + ltkhid <- encodeKeyHashid ltid + let actors = [LocalActorSharer shrUser] + collections = + [ LocalPersonCollectionProjectTeam shrJ prj + , LocalPersonCollectionProjectFollowers shrJ prj + ] + recips = + map encodeRouteHome $ + map renderLocalActor actors ++ + map renderLocalPersonCollection collections + doc = Doc hLocal Activity + { activityId = + Just $ encodeRouteLocal $ + ProjectOutboxItemR shrJ prj obikhidAccept + , activityActor = encodeRouteLocal $ ProjectR shrJ prj + , activitySummary = Nothing + , activityAudience = Audience recips [] [] [] [] [] + , activitySpecific = AcceptActivity Accept + { acceptObject = ObjURI hLocal luOffer + , acceptResult = + Just $ encodeRouteLocal $ ProjectTicketR shrJ prj ltkhid } - ltid <- insert LocalTicket - { localTicketTicket = tid - , localTicketDiscuss = did - , localTicketFollowers = fsid - } - tclid <- insert TicketContextLocal - { ticketContextLocalTicket = tid - , ticketContextLocalAccept = obiidAccept - } - insert_ TicketProjectLocal - { ticketProjectLocalContext = tclid - , ticketProjectLocalProject = jid - } - talid <- insert TicketAuthorLocal - { ticketAuthorLocalTicket = ltid - , ticketAuthorLocalAuthor = pidAuthor - , ticketAuthorLocalOpen = obiid - } - insert_ TicketUnderProject - { ticketUnderProjectProject = tclid - , ticketUnderProjectAuthor = talid - } - --insertMany_ $ map (TicketDependency tid) tidsDeps - -- insert_ $ Follow pidAuthor fsid False True - return ltid - publishAccept pidAuthor sid jid fsid luOffer {-num-} obiid doc = do - now <- liftIO getCurrentTime - let dont = Authority "dont-do.any-forwarding" Nothing - remotesHttp <- do - moreRemotes <- deliverLocal now sid fsid obiid - deliverRemoteDB' dont obiid [] moreRemotes - site <- askSite - liftIO $ runWorker (deliverRemoteHttp dont obiid doc remotesHttp) site - where - deliverLocal now sid fsid obiid = do - (pidsTeam, remotesTeam) <- getProjectTeam sid - (pidsFollowers, remotesFollowers) <- getFollowers fsid - let pids = LO.insertSet pidAuthor $ LO.union pidsTeam pidsFollowers - remotes = unionRemotes remotesTeam remotesFollowers - for_ pids $ \ pid -> do - ibid <- personInbox <$> getJust pid - ibiid <- insert $ InboxItem True - insert_ $ InboxItemLocal ibid obiid ibiid - return remotes + } + update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc] + return (doc, makeRecipientSet actors collections) undoC :: ShrIdent diff --git a/src/Vervis/Handler/Client.hs b/src/Vervis/Handler/Client.hs index 7d5963c..2c784c5 100644 --- a/src/Vervis/Handler/Client.hs +++ b/src/Vervis/Handler/Client.hs @@ -301,7 +301,7 @@ postSharerOutboxR shr = do OfferActivity (Offer obj target) -> case obj of OfferTicket ticket -> - offerTicketC shr summary audience ticket target + offerTicketC eperson sharer summary audience ticket target _ -> throwE "Unsupported Offer 'object' type" UndoActivity undo -> undoC shr summary audience undo @@ -336,7 +336,7 @@ postPublishR = do FormMissing -> throwE "Field(s) missing" FormFailure _l -> throwE "Invalid input, see below" FormSuccess r -> return r - bitraverse (bitraverse (publishComment ep s) (publishTicket ep s)) (bitraverse (openTicket shrAuthor) (follow shrAuthor)) input + bitraverse (bitraverse (publishComment ep s) (publishTicket ep s)) (bitraverse (openTicket ep s) (follow shrAuthor)) input case eid of Left err -> setMessage $ toHtml err Right id_ -> @@ -412,11 +412,12 @@ postPublishR = do _ -> error "Create object isn't a ticket" target = createTarget create createTicketC eperson sharer (Just summary) audience ticket target - openTicket shrAuthor ((h, shr, prj), TextHtml title, TextPandocMarkdown desc) = do + openTicket eperson sharer ((h, shr, prj), TextHtml title, TextPandocMarkdown desc) = do encodeRouteLocal <- getEncodeRouteLocal encodeRouteFed <- getEncodeRouteFed local <- hostIsLocal h descHtml <- ExceptT . pure $ renderPandocMarkdown desc + let shrAuthor = sharerIdent sharer summary <- TextHtml . TL.toStrict . renderHtml <$> withUrlRenderer @@ -459,7 +460,7 @@ postPublishR = do , audienceGeneral = [] , audienceNonActors = map (encodeRouteFed h) recipsC } - offerTicketC shrAuthor (Just summary) audience ticketAP target + offerTicketC eperson sharer (Just summary) audience ticketAP target follow shrAuthor (uObject@(ObjURI hObject luObject), uRecip) = do (summary, audience, followAP) <- C.follow shrAuthor uObject uRecip False @@ -788,7 +789,7 @@ postProjectTicketsR shr prj = do then Right <$> do (summary, audience, ticket, target) <- ExceptT $ offerTicket shrAuthor (TextHtml title) (TextPandocMarkdown desc) shr prj - obiid <- offerTicketC shrAuthor (Just summary) audience ticket target + obiid <- offerTicketC eperson sharer (Just summary) audience ticket target ExceptT $ runDB $ do mtal <- getValBy $ UniqueTicketAuthorLocalOpen obiid return $