From de2e29d50573f8e94097b31243357197de760a08 Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Wed, 21 Sep 2022 12:50:26 +0000 Subject: [PATCH] C2S: offerTicketC re-enabled and supporting looms and remote origin repo What's missing: - Match patch VCS, origin repo VCS and target repo VCS - Hook into postPersonInboxR - If only origin is provided, generate patches / otherwise somehow remember the commits proposed --- migrations/495_2022-09-21_ticket_title.model | 19 + src/Database/Persist/Local.hs | 2 +- src/Vervis/API.hs | 744 +++++++++---------- src/Vervis/Client.hs | 7 +- src/Vervis/Data/Ticket.hs | 196 +++++ src/Vervis/Handler/Cloth.hs | 9 +- src/Vervis/Handler/Ticket.hs | 17 +- src/Vervis/Migration.hs | 10 + src/Vervis/Migration/Model.hs | 4 + src/Vervis/Model.hs | 1 + src/Web/ActivityPub.hs | 40 +- src/Web/Text.hs | 77 ++ templates/cloth/one.hamlet | 2 +- templates/ticket/one.hamlet | 2 +- th/models | 6 +- vervis.cabal | 4 + 16 files changed, 725 insertions(+), 415 deletions(-) create mode 100644 migrations/495_2022-09-21_ticket_title.model create mode 100644 src/Vervis/Data/Ticket.hs create mode 100644 src/Web/Text.hs diff --git a/migrations/495_2022-09-21_ticket_title.model b/migrations/495_2022-09-21_ticket_title.model new file mode 100644 index 0000000..2f3dc08 --- /dev/null +++ b/migrations/495_2022-09-21_ticket_title.model @@ -0,0 +1,19 @@ +Discussion +FollowerSet +OutboxItem + +Ticket + number Int Maybe + created UTCTime + title Text + source Text + description HTML + status Text + discuss DiscussionId + followers FollowerSetId + accept OutboxItemId + + -- UniqueTicket project number + UniqueTicketDiscuss discuss + UniqueTicketFollowers followers + UniqueTicketAccept accept diff --git a/src/Database/Persist/Local.hs b/src/Database/Persist/Local.hs index b0a07c2..7d264d5 100644 --- a/src/Database/Persist/Local.hs +++ b/src/Database/Persist/Local.hs @@ -118,4 +118,4 @@ getEntityE , PersistRecordBackend record backend ) => Key record -> e -> ExceptT e (ReaderT backend m) (Entity record) -getEntityE key msg = (Entity key) <$> getE key msg +getEntityE key msg = Entity key <$> getE key msg diff --git a/src/Vervis/API.hs b/src/Vervis/API.hs index 9ee4758..0779bcb 100644 --- a/src/Vervis/API.hs +++ b/src/Vervis/API.hs @@ -41,15 +41,18 @@ import Control.Monad import Control.Monad.Trans.Except import Control.Monad.Trans.Maybe import Control.Monad.Trans.Reader +import Data.Align import Data.Barbie import Data.Bifunctor import Data.Bifoldable import Data.Bitraversable import Data.Foldable +import Data.Functor import Data.Functor.Identity import Data.List.NonEmpty (NonEmpty (..)) import Data.Maybe import Data.Text (Text) +import Data.These import Data.Time.Clock import Data.Traversable import Database.Persist hiding (deleteBy) @@ -60,6 +63,7 @@ import Text.Blaze.Html.Renderer.Text import Yesod.Core hiding (logError, logWarn, logInfo, logDebug) import Yesod.Persist.Core +import qualified Data.List.NonEmpty as NE import qualified Data.Text as T import qualified Data.Text.Lazy as TL @@ -67,6 +71,7 @@ import Database.Persist.JSON import Development.PatchMediaType import Network.FedURI import Web.ActivityPub hiding (Patch, Ticket, Follow, Repo (..), ActorLocal (..), ActorDetail (..), Actor (..)) +import Web.Text import Yesod.ActivityPub import Yesod.FedURI import Yesod.Hashids @@ -86,6 +91,7 @@ import Vervis.ActivityPub import Vervis.Cloth import Vervis.Data.Actor import Vervis.Data.Collab +import Vervis.Data.Ticket import Vervis.Delivery import Vervis.FedURI import Vervis.Foundation @@ -133,7 +139,7 @@ verifyRemoteAddressed remoteRecips u = acceptC :: Entity Person -> Actor - -> Maybe TextHtml + -> Maybe HTML -> Audience URIMode -> Accept URIMode -> ExceptT Text Handler OutboxItemId @@ -373,7 +379,7 @@ acceptC (Entity senderPersonID senderPerson) senderActor summary audience accept addBundleC :: Entity Person - -> Maybe TextHtml + -> Maybe HTML -> Audience URIMode -> NonEmpty (AP.Patch URIMode) -> FedURI @@ -572,7 +578,7 @@ addBundleC (Entity pidUser personUser) summary audience patches uTarget = do applyC :: Entity Person - -> Maybe TextHtml + -> Maybe HTML -> Audience URIMode -> Maybe (ObjURI URIMode) -> Apply URIMode @@ -1012,7 +1018,7 @@ noteC eperson@(Entity personID person) note = do personHash <- encodeKeyHashid personID let username = personUsername person summary <- - TextHtml . TL.toStrict . renderHtml <$> + renderHTML <$> withUrlRenderer [hamlet|

@@ -1030,7 +1036,7 @@ noteC eperson@(Entity personID person) note = do -- error message if the Note is rejected, otherwise the new 'LocalMessageId'. createNoteC :: Entity Person - -> Maybe TextHtml + -> Maybe HTML -> Audience URIMode -> Note URIMode -> Maybe FedURI @@ -1260,28 +1266,10 @@ checkFederation remoteRecips = do unless (federation || null remoteRecips) $ throwE "Federation disabled, but remote recipients found" -{- -verifyProjectRecip (Right _) _ = return () -verifyProjectRecip (Left (WITProject 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 -verifyProjectRecip (Left (WITRepo shr rp _ _ _)) localRecips = - fromMaybeE verify "Local context repo isn't listed as a recipient" - where - verify = do - sharerSet <- lookup shr localRecips - repoSet <- lookup rp $ localRecipRepoRelated sharerSet - guard $ localRecipRepo $ localRecipRepoDirect repoSet --} - createPatchTrackerC :: Entity Person -> Actor - -> Maybe TextHtml + -> Maybe HTML -> Audience URIMode -> AP.ActorDetail -> NonEmpty FedURI @@ -1551,7 +1539,7 @@ createPatchTrackerC (Entity pidUser personUser) senderActor summary audience det createRepositoryC :: Entity Person -> Actor - -> Maybe TextHtml + -> Maybe HTML -> Audience URIMode -> AP.ActorDetail -> VersionControlSystem @@ -1815,7 +1803,7 @@ createRepositoryC (Entity pidUser personUser) senderActor summary audience detai createTicketTrackerC :: Entity Person -> Actor - -> Maybe TextHtml + -> Maybe HTML -> Audience URIMode -> AP.ActorDetail -> Maybe (Host, AP.ActorLocal URIMode) @@ -2067,7 +2055,7 @@ data Followee followC :: Entity Person - -> Maybe TextHtml + -> Maybe HTML -> Audience URIMode -> AP.Follow URIMode -> ExceptT Text Handler OutboxItemId @@ -2197,7 +2185,7 @@ followC (Entity pidSender personSender) summary audience follow@(AP.Follow uObje insertAcceptToOutbox senderHash luFollow actorRecip obidRecip = do now <- liftIO getCurrentTime summary <- - TextHtml . TL.toStrict . renderHtml <$> + renderHTML <$> withUrlRenderer [hamlet|

@@ -2256,7 +2244,7 @@ inviteC :: Entity Person -> Actor -> Maybe FedURI - -> Maybe TextHtml + -> Maybe HTML -> Audience URIMode -> Invite URIMode -> ExceptT Text Handler OutboxItemId @@ -2504,387 +2492,393 @@ inviteC (Entity senderPersonID senderPerson) senderActor muCap summary audience offerTicketC :: Entity Person - -> Maybe TextHtml + -> Actor + -> Maybe HTML -> Audience URIMode -> AP.Ticket URIMode -> FedURI -> ExceptT Text Handler OutboxItemId -offerTicketC (Entity pidUser personUser) summary audience ticket uTarget = do - error "offerTicketC temporarily disabled" +offerTicketC (Entity senderPersonID senderPerson) senderActor summary audience ticket uTarget = do - -{- - senderHash <- encodeKeyHashid pidUser - - - - - - - (target, title, desc, source) <- checkOfferTicket shrUser ticket uTarget + -- Check input + (title, desc, source, tam) <- do + hostLocal <- asksSite siteInstanceHost + WorkItemOffer {..} <- checkOfferTicket hostLocal ticket uTarget + unless (wioAuthor == Left senderPersonID) $ + throwE "Offering a Ticket attributed to someone else" + return (wioTitle, wioDesc, wioSource, wioRest) ParsedAudience localRecips remoteRecips blinded fwdHosts <- do mrecips <- parseAudience audience fromMaybeE mrecips "Offer Ticket with no recipients" - federation <- asksSite $ appFederation . appSettings - unless (federation || null remoteRecips) $ - throwE "Federation disabled, but remote recipients specified" - verifyProjectRecip target localRecips + checkFederation remoteRecips + + -- Verify that the target tracker is addressed by the Offer + case tam of + TAM_Task deckID -> do + deckHash <- encodeKeyHashid deckID + unless (actorIsAddressed localRecips $ LocalActorDeck deckHash) $ + throwE "Local target deck not addressed by the Offer" + TAM_Merge loomID _ -> do + loomHash <- encodeKeyHashid loomID + unless (actorIsAddressed localRecips $ LocalActorLoom loomHash) $ + throwE "Local target loom not addressed by the Offer" + TAM_Remote uTracker _ -> verifyRemoteAddressed remoteRecips uTracker + + senderHash <- encodeKeyHashid senderPersonID now <- liftIO getCurrentTime - (obiidOffer, docOffer, remotesHttpOffer, maybeAccept) <- runDBExcept $ do - mproject <- - case target of - Left (WITProject shr prj) -> Just . Left <$> do - mproj <- lift $ runMaybeT $ do - Entity sid s <- MaybeT $ getBy $ UniqueSharer shr - ej@(Entity _ j) <- MaybeT $ getBy $ UniqueProject prj sid - a <- lift $ getJust $ projectActor j - return (s, ej, a) - fromMaybeE mproj "Offer target no such local project in DB" - Left (WITRepo shr rp mb typ diffs) -> Just . Right <$> do - mproj <- lift $ runMaybeT $ do - Entity sid s <- MaybeT $ getBy $ UniqueSharer shr - er <- MaybeT $ getBy $ UniqueRepo rp sid - return (s, er) - (s, er@(Entity _ r)) <- fromMaybeE mproj "Offer target no such local repo in DB" - unless (repoVcs r == patchMediaTypeVCS typ) $ - throwE "Patch type and repo VCS mismatch" - return (s, er, mb, typ, diffs) - Right _ -> return Nothing - (obiid, doc, luOffer) <- lift $ insertOfferToOutbox shrUser now (personOutbox personUser) blinded - remotesHttpOffer <- do - let sieve = - case target of - Left (WITProject shr prj) -> - makeRecipientSet - [ LocalActorProject shr prj - ] - [ LocalPersonCollectionSharerFollowers shrUser - , LocalPersonCollectionProjectTeam shr prj - , LocalPersonCollectionProjectFollowers shr prj - ] - Left (WITRepo shr rp _ _ _) -> - makeRecipientSet - [ LocalActorRepo shr rp - ] - [ LocalPersonCollectionSharerFollowers shrUser - , LocalPersonCollectionRepoTeam shr rp - , LocalPersonCollectionRepoFollowers shr rp - ] - Right _ -> - makeRecipientSet - [] - [LocalPersonCollectionSharerFollowers shrUser] + + -- If tracker is a local loom, and a remote origin repo is specified, fetch + -- that repo's AP object via HTTP and remember in DB + maybeLocalTracker <- + case tam of + TAM_Task deckID -> pure $ Just $ Left deckID + TAM_Merge loomID (Merge maybeOriginTip maybeBundle targetTip) -> do + maybeOrigin <- for maybeOriginTip $ \case + TipLocalRepo repoID -> pure $ Left (repoID, Nothing) + TipLocalBranch repoID branch -> pure $ Left (repoID, Just branch) + TipRemote uOrigin -> Right <$> do + (vcs, raid, mb) <- withExceptT (T.pack . show) $ httpGetRemoteTip uOrigin + return (vcs, raid, first Just <$> mb) + TipRemoteBranch uRepo branch -> Right <$> do + (vcs, raid) <- withExceptT (T.pack . show) $ httpGetRemoteRepo uRepo + return (vcs, raid, Just (Nothing, branch)) + originOrBundle <- + fromMaybeE + (align maybeOrigin maybeBundle) + "MR provides neither origin nor patches" + (targetRepoID, maybeTargetBranch) <- + case targetTip of + TipLocalRepo repoID -> pure (repoID, Nothing) + TipLocalBranch repoID branch -> pure (repoID, Just branch) + _ -> throwE "Offer target is a local loom but MR target is a remote repo (Looms serve only local repos)" + return $ Just $ Right (loomID, originOrBundle, targetRepoID, maybeTargetBranch) + TAM_Remote _ _ -> pure Nothing + + (offerID, deliverHttpOffer, maybeDeliverHttpAccept) <- runDBExcept $ do + + -- If target tracker is local, find it in our DB + -- If that tracker is a loom, find and check the MR too + maybeLocalTrackerDB <- for maybeLocalTracker $ bitraverse + (\ deckID -> do + deck <- getE deckID "Offer local target no such deck in DB" + return (deckID, deckActor deck) + ) + (\ (loomID, originOrBundle, targetRepoID, maybeTargetBranch) -> do + loom <- getE loomID "Offer local target no such loom in DB" + + unless (targetRepoID == loomRepo loom) $ + throwE "MR target repo isn't the one served by the Offer target loom" + targetRepo <- getE targetRepoID "MR target local repo not found in DB" + unless (repoLoom targetRepo == Just loomID) $ + throwE "Offer target loom doesn't have repo's consent to serve it" + + originOrBundle' <- + bitraverse + (bitraverse + (\ (repoID, maybeBranch) -> do + repo <- getE repoID "MR origin local repo not found in DB" + return (repoID, repoVcs repo, maybeBranch) + ) + pure + ) + pure + originOrBundle + + return (loomID, loomActor loom, originOrBundle', targetRepoID, maybeTargetBranch) + ) + + -- Insert Offer to sender's outbox + offerID <- lift $ insertEmptyOutboxItem (actorOutbox senderActor) now + docOffer <- lift $ insertOfferToOutbox senderHash blinded offerID + + -- Deliver the Offer activity to local recipients, and schedule + -- delivery for unavailable remote recipients + remoteRecipsHttpOffer <- do + hashRepo <- getEncodeKeyHashid + let tipRepo tip = + case tip of + TipLocalRepo repoID -> Just $ hashRepo repoID + TipLocalBranch repoID _ -> Just $ hashRepo repoID + _ -> Nothing + hashDeck <- getEncodeKeyHashid + hashLoom <- getEncodeKeyHashid + let (tracker, target, origin) = + case tam of + TAM_Task deckID -> + ( Just $ Left $ hashDeck deckID + , Nothing + , Nothing + ) + TAM_Merge loomID (Merge maybeOriginTip _ targetTip) -> + ( Just $ Right $ hashLoom loomID + , tipRepo targetTip + , tipRepo =<< maybeOriginTip + ) + TAM_Remote _ maybeMerge -> + ( Nothing + , tipRepo . mergeTarget =<< maybeMerge + , tipRepo =<< mergeOrigin =<< maybeMerge + ) + sieveActors = catMaybes + [ tracker <&> \case + Left deckHash -> LocalActorDeck deckHash + Right loomHash -> LocalActorLoom loomHash + , LocalActorRepo <$> target + , LocalActorRepo <$> origin + ] + sieveStages = catMaybes + [ tracker <&> \case + Left deckHash -> LocalStageDeckFollowers deckHash + Right loomHash -> LocalStageLoomFollowers loomHash + , LocalStageRepoFollowers <$> target + , LocalStageRepoFollowers <$> origin + , Just $ LocalStagePersonFollowers senderHash + ] + sieve = makeRecipientSet sieveActors sieveStages 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'' fwdHosts obiid remoteRecips moreRemoteRecips - maccept <- lift $ for mproject $ \ project -> do - let obid = - case project of - Left (_, _, a) -> actorOutbox a - Right (_, Entity _ r, _, _, _) -> repoOutbox r - obiidAccept <- insertEmptyOutboxItem obid now - let insertTXL = - case project of - Left (_, Entity jid _, _) -> - \ tclid -> insert_ $ TicketProjectLocal tclid jid - Right (_, Entity rid _, mb, _, _) -> - \ tclid -> insert_ $ TicketRepoLocal tclid rid mb - (tid, ltid) <- insertTicket pidUser now title desc source insertTXL obiid obiidAccept - case project of - Left _ -> return () - Right (_, _, _, typ, diffs) -> do - bnid <- insert $ Bundle tid - insertMany_ $ NE.toList $ NE.map (Patch bnid now typ) diffs - (docAccept, localRecipsAccept) <- insertAccept shrUser luOffer project obiidAccept ltid - let (actor, ibid) = - case project of - Left (s, Entity _ j, a) -> - ( LocalActorProject (sharerIdent s) (projectIdent j) - , actorInbox a - ) - Right (s, Entity _ r, _, _, _) -> - ( LocalActorRepo (sharerIdent s) (repoIdent r) - , repoInbox r - ) - knownRemoteRecipsAccept <- - deliverLocal' False actor ibid obiidAccept localRecipsAccept - (obiidAccept,docAccept,) <$> deliverRemoteDB'' [] obiidAccept [] knownRemoteRecipsAccept - return (obiid, doc, remotesHttpOffer, maccept) + lift $ deliverLocal' True (LocalActorPerson senderHash) (personActor senderPerson) offerID $ + localRecipSieve sieve False localRecips + checkFederation moreRemoteRecips + lift $ deliverRemoteDB'' fwdHosts offerID remoteRecips moreRemoteRecips + + -- If Offer target is a local deck/loom, verify that it has received + -- the Offer, insert a new Ticket to DB, and publish Accept + maybeDeliverHttpAccept <- for maybeLocalTrackerDB $ \ tracker -> do + + -- Verify that tracker received the Offer + let trackerActorID = + case tracker of + Left (_, actorID) -> actorID + Right (_, actorID, _, _, _) -> actorID + verifyActorHasItem trackerActorID offerID "Local tracker didn't receive the Offer" + + -- Insert ticket/MR to DB + acceptID <- lift $ do + trackerActor <- getJust trackerActorID + insertEmptyOutboxItem (actorOutbox trackerActor) now + ticketRoute <- lift $ do + ticketID <- insertTicket now title desc source offerID acceptID + case tracker of + Left (deckID, _) -> insertTask deckID ticketID + Right (loomID, _, originOrBundle, _, maybeTargetBranch) -> + insertMerge now loomID ticketID maybeTargetBranch originOrBundle + + -- Insert an Accept activity to tracker's outbox + hashDeck <- getEncodeKeyHashid + hashLoom <- getEncodeKeyHashid + let acceptRecipActors = [LocalActorPerson senderHash] + acceptRecipStages = + [ case tracker of + Left (deckID, _) -> + LocalStageDeckFollowers $ hashDeck deckID + Right (loomID, _, _, _, _) -> + LocalStageLoomFollowers $ hashLoom loomID + , LocalStagePersonFollowers senderHash + ] + docAccept <- + lift $ insertAcceptToOutbox senderHash tracker ticketRoute offerID acceptID acceptRecipActors acceptRecipStages + + -- Deliver the Accept activity to local recipients, and schedule + -- delivery for unavailable remote recipients + remoteRecipsHttpAccept <- do + let trackerLocalActor = + case tracker of + Left (deckID, _) -> + LocalActorDeck $ hashDeck deckID + Right (loomID, _, _, _, _) -> + LocalActorLoom $ hashLoom loomID + remoteRecips <- + lift $ deliverLocal' True trackerLocalActor trackerActorID acceptID $ + makeRecipientSet acceptRecipActors acceptRecipStages + checkFederation remoteRecips + lift $ deliverRemoteDB'' [] acceptID [] remoteRecips + + -- Return instructions for HTTP delivery to remote recipients + return $ + deliverRemoteHttp' [] acceptID docAccept remoteRecipsHttpAccept + + -- Return instructions for HTTP delivery to remote recipients + return + ( offerID + , deliverRemoteHttp' fwdHosts offerID docOffer remoteRecipsHttpOffer + , maybeDeliverHttpAccept + ) + + -- Launch asynchronous HTTP delivery of Offer and Accept lift $ do - forkWorker "offerTicketC: async HTTP Offer delivery" $ deliverRemoteHttp' fwdHosts obiidOffer docOffer remotesHttpOffer - for_ maybeAccept $ \ (obiidAccept, docAccept, remotesHttpAccept) -> - forkWorker "offerTicketC: async HTTP Accept delivery" $ deliverRemoteHttp' [] obiidAccept docAccept remotesHttpAccept - return obiidOffer + forkWorker "offerTicketC: async HTTP Offer delivery" deliverHttpOffer + for_ maybeDeliverHttpAccept $ + forkWorker "offerTicketC: async HTTP Accept delivery" + + return offerID + + --unless (repoVcs r == patchMediaTypeVCS typ) $ + -- throwE "Patch type and repo VCS mismatch" + where + fetchRepoE h lu = do + manager <- asksSite getHttpManager + let apRepoId = AP.actorId . AP.actorLocal . AP.repoActor + ExceptT $ first (maybe ResultIdMismatch ResultGetError) <$> + fetchAPID' manager apRepoId h lu + insertRemoteActor h lu (AP.Actor local detail) = do + iid <- either entityKey id <$> insertBy' (Instance h) + roid <- either entityKey id <$> insertBy' (RemoteObject iid lu) + let ra = RemoteActor + { remoteActorIdent = roid + , remoteActorName = + AP.actorName detail <|> AP.actorUsername detail + , remoteActorInbox = AP.actorInbox local + , remoteActorFollowers = AP.actorFollowers local + , remoteActorErrorSince = Nothing + } + either entityKey id <$> insertBy' ra - - - - - - - - - checkOfferTicket - :: ShrIdent - -> AP.Ticket URIMode - -> FedURI - -> ExceptT Text Handler - ( Either WorkItemTarget (Host, LocalURI, Maybe (Maybe LocalURI, PatchMediaType, NonEmpty Text)) - , TextHtml - , TextHtml - , TextPandocMarkdown + httpGetRemoteTip + :: FedURI + -> ExceptT Result Handler + ( VersionControlSystem + , RemoteActorId + , Maybe (LocalURI, Text) ) - checkOfferTicket shrUser??? ticket uTarget = do - - - - - - - - - - - - - - - - target <- parseTarget uTarget - (muContext, summary, content, source, mmr) <- checkTicket shrUser ticket - for_ muContext $ - \ u -> unless (u == uTarget) $ throwE "Offer target != ticket context" - target' <- matchTargetAndMR target mmr - return (target', summary, content, source) + httpGetRemoteTip (ObjURI host localURI) = do + repoOrBranch <- fetchTipE host localURI + case repoOrBranch of + Left repo -> do + remoteActorID <- + lift $ runSiteDB $ + insertRemoteActor host localURI $ AP.repoActor repo + return (AP.repoVcs repo, remoteActorID, Nothing) + Right (AP.Branch name _ luRepo) -> do + repo <- fetchRepoE host luRepo + remoteActorID <- + lift $ runSiteDB $ + insertRemoteActor host luRepo $ AP.repoActor repo + return (AP.repoVcs repo, remoteActorID, Just (localURI, name)) where - 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 - DeckR d t -> return $ Left (d, t) - LoomR l c -> return $ Right (l, c) - _ -> throwE "Offer target is local but isn't a deck/loom route" - else return $ Right u + fetchTipE h lu = do + manager <- asksSite getHttpManager + ExceptT $ first (maybe ResultIdMismatch ResultGetError) <$> + fetchTip manager h lu + httpGetRemoteRepo + :: FedURI -> ExceptT Result Handler (VersionControlSystem, RemoteActorId) + httpGetRemoteRepo (ObjURI host localURI) = do + repo <- fetchRepoE host localURI + remoteActorID <- + lift $ runSiteDB $ + insertRemoteActor host localURI $ AP.repoActor repo + return (AP.repoVcs repo, remoteActorID) - - - - - - - - checkTicket - shrUser - (AP.Ticket mlocal attrib mpublished mupdated muContext summary - content source muAssigned mresolved mmr) = 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 mpublished "Ticket with 'published'" - verifyNothingE mupdated "Ticket with 'updated'" - verifyNothingE muAssigned "Ticket has 'assignedTo'" - when (isJust mresolved) $ throwE "Ticket is resolved" - - mmr' <- traverse (uncurry checkMR) mmr - - return (muContext, summary, content, source, mmr') - where - checkMR h (MergeRequest muOrigin luTarget ebundle) = do - verifyNothingE muOrigin "MR with 'origin'" - branch <- checkBranch h luTarget - (typ, diffs) <- - case ebundle of - Left _ -> throwE "MR bundle specified as a URI" - Right (hBundle, bundle) -> checkBundle hBundle bundle - case (typ, diffs) of - (PatchMediaTypeDarcs, _ :| _ : _) -> - throwE "More than one Darcs patch bundle provided" - _ -> return () - return (branch, typ, diffs) - where - checkBranch h lu = do - hl <- hostIsLocal h - if hl - then Left <$> do - route <- - fromMaybeE - (decodeRouteLocal lu) - "MR target is local but isn't a valid route" - case route of - RepoR shr rp -> return (shr, rp, Nothing) - RepoBranchR shr rp b -> return (shr, rp, Just b) - _ -> - throwE - "MR target is a valid local route, but isn't a \ - \repo or branch route" - else return $ Right $ ObjURI h lu - checkBundle _ (AP.BundleHosted _ _) = - throwE "Patches specified as URIs" - checkBundle h (AP.BundleOffer mlocal patches) = do - verifyNothingE mlocal "Bundle has 'id'" - (typ:|typs, diffs) <- NE.unzip <$> traverse (checkPatch h) patches - unless (all (== typ) typs) $ throwE "Different patch types" - return (typ, diffs) - where - checkPatch h (AP.Patch mlocal attrib mpub typ content) = do - verifyNothingE mlocal "Patch with 'id'" - hl <- hostIsLocal h - shrAttrib <- do - route <- fromMaybeE (decodeRouteLocal attrib) "Patch attrib not a valid route" - case route of - SharerR shr -> return shr - _ -> throwE "Patch attrib not a sharer route" - unless (hl && shrAttrib == shrUser) $ - throwE "Ticket and Patch attrib mismatch" - verifyNothingE mpub "Patch has 'published'" - return (typ, content) - matchTargetAndMR (Left (Left (shr, prj))) Nothing = return $ Left $ WITProject shr prj - matchTargetAndMR (Left (Left (shr, prj))) (Just _) = throwE "Patch offered to project" - matchTargetAndMR (Left (Right (shr, rp))) Nothing = throwE "Issue offered to repo" - matchTargetAndMR (Left (Right (shr, rp))) (Just (branch, typ, diffs)) = do - branch' <- - case branch of - Left (shr', rp', mb) | shr == shr' && rp == rp' -> return mb - _ -> throwE "MR target repo/branch and Offer target repo mismatch" - case patchMediaTypeVCS typ of - VCSDarcs -> - unless (isNothing branch') $ - throwE "Darcs MR specifies a branch" - VCSGit -> - unless (isJust branch') $ - throwE "Git MR doesn't specify the branch" - return $ Left $ WITRepo shr rp branch' typ diffs - matchTargetAndMR (Right (ObjURI h lu)) Nothing = return $ Right (h, lu, Nothing) - matchTargetAndMR (Right (ObjURI h lu)) (Just (branch, typ, diffs)) = do - luBranch <- - case branch of - Right (ObjURI h' lu') | h == h' -> return lu - _ -> throwE "MR target repo/branch and Offer target repo mismatch" - let bundle = - ( if lu == luBranch then Nothing else Just luBranch - , typ - , diffs - ) - return $ Right (h, lu, Just bundle) - - insertOfferToOutbox shrUser now obid blinded = do - hLocal <- asksSite siteInstanceHost - obiid <- insertEmptyOutboxItem obid now + insertOfferToOutbox senderHash blinded offerID = do encodeRouteLocal <- getEncodeRouteLocal - obikhid <- encodeKeyHashid obiid - let luAct = encodeRouteLocal $ SharerOutboxItemR shrUser obikhid - doc = Doc hLocal Activity - { activityId = Just luAct - , activityActor = encodeRouteLocal $ SharerR shrUser + hLocal <- asksSite siteInstanceHost + offerHash <- encodeKeyHashid offerID + let doc = Doc hLocal Activity + { activityId = + Just $ encodeRouteLocal $ + PersonOutboxItemR senderHash offerHash + , activityActor = encodeRouteLocal $ PersonR senderHash , activityCapability = Nothing - , activitySummary = summary - , activityAudience = blinded - , activitySpecific = + , activitySummary = summary + , activityAudience = blinded + , activityFulfills = [] + , activitySpecific = OfferActivity $ Offer (OfferTicket ticket) uTarget } - update obiid [OutboxItemActivity =. persistJSONObjectFromDoc doc] - return (obiid, doc, luAct) - insertTicket pidAuthor now title desc source insertTXL obiid obiidAccept = do + update offerID [OutboxItemActivity =. persistJSONObjectFromDoc doc] + return doc + + insertTicket now title desc source offerID acceptID = 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 + , ticketTitle = title + , ticketSource = source + , ticketDescription = desc , ticketStatus = TSNew + , ticketDiscuss = did + , ticketFollowers = fsid + , ticketAccept = acceptID } - ltid <- insert LocalTicket - { localTicketTicket = tid - , localTicketDiscuss = did - , localTicketFollowers = fsid + insert_ TicketAuthorLocal + { ticketAuthorLocalTicket = tid + , ticketAuthorLocalAuthor = senderPersonID + , ticketAuthorLocalOpen = offerID } - tclid <- insert TicketContextLocal - { ticketContextLocalTicket = tid - , ticketContextLocalAccept = obiidAccept - } - insertTXL tclid - talid <- insert TicketAuthorLocal - { ticketAuthorLocalTicket = ltid - , ticketAuthorLocalAuthor = pidAuthor - , ticketAuthorLocalOpen = obiid - } - insert_ TicketUnderProject - { ticketUnderProjectProject = tclid - , ticketUnderProjectAuthor = talid - } - return (tid, ltid) - insertAccept shrUser luOffer project obiidAccept ltid = do - let (collections, outboxItemRoute, projectRoute, ticketRoute) = - case project of - Left (s, Entity _ j, _) -> - let shr = sharerIdent s - prj = projectIdent j - in ( [ LocalPersonCollectionProjectTeam shr prj - , LocalPersonCollectionProjectFollowers shr prj - ] - , ProjectOutboxItemR shr prj - , ProjectR shr prj - , ProjectTicketR shr prj - ) - Right (s, Entity _ r, _, _, _) -> - let shr = sharerIdent s - rp = repoIdent r - in ( [ LocalPersonCollectionRepoTeam shr rp - , LocalPersonCollectionRepoFollowers shr rp - ] - , RepoOutboxItemR shr rp - , RepoR shr rp - , RepoProposalR shr rp - ) + return tid + + insertTask deckID ticketID = do + ticketDeckID <- insert $ TicketDeck ticketID deckID + TicketR <$> encodeKeyHashid deckID <*> encodeKeyHashid ticketDeckID + + insertMerge + :: UTCTime + -> LoomId + -> TicketId + -> Maybe Text + -> These + (Either + (RepoId, VersionControlSystem, Maybe Text) + (VersionControlSystem, RemoteActorId, Maybe (Maybe LocalURI, Text)) + ) + Material + -> AppDB (Route App) + insertMerge now loomID ticketID maybeBranch originOrBundle = do + clothID <- insert $ TicketLoom ticketID loomID maybeBranch + for_ (justHere originOrBundle) $ \case + Left (repoID, _, maybeOriginBranch) -> + insert_ $ MergeOriginLocal clothID repoID maybeOriginBranch + Right (_, remoteActorID, maybeOriginBranch) -> do + originID <- insert $ MergeOriginRemote clothID remoteActorID + for_ maybeOriginBranch $ \ (mlu, b) -> + insert_ $ MergeOriginRemoteBranch originID mlu b + for_ (justThere originOrBundle) $ \ (Material typ diffs) -> do + bundleID <- insert $ Bundle clothID + insertMany_ $ NE.toList $ NE.reverse $ + NE.map (Patch bundleID now typ) diffs + ClothR <$> encodeKeyHashid loomID <*> encodeKeyHashid clothID + + insertAcceptToOutbox personHash tracker ticketRoute offerID acceptID actors stages = do encodeRouteLocal <- getEncodeRouteLocal encodeRouteHome <- getEncodeRouteHome + tracker' <- + bitraverse + (\ (deckID, _) -> encodeKeyHashid deckID) + (\ (loomID, _, _, _, _) -> encodeKeyHashid loomID) + tracker hLocal <- asksSite siteInstanceHost - obikhidAccept <- encodeKeyHashid obiidAccept - ltkhid <- encodeKeyHashid ltid - let actors = [LocalActorSharer shrUser] - recips = + offerHash <- encodeKeyHashid offerID + acceptHash <- encodeKeyHashid acceptID + let recips = map encodeRouteHome $ - map renderLocalActor actors ++ - map renderLocalPersonCollection collections + map renderLocalActor actors ++ + map renderLocalStage stages doc = Doc hLocal Activity - { activityId = - Just $ encodeRouteLocal $ outboxItemRoute obikhidAccept - , activityActor = encodeRouteLocal projectRoute + { activityId = + Just $ encodeRouteLocal $ + case tracker' of + Left deckHash -> DeckOutboxItemR deckHash acceptHash + Right loomHash -> LoomOutboxItemR loomHash acceptHash + , activityActor = + encodeRouteLocal $ either DeckR LoomR tracker' , activityCapability = Nothing - , activitySummary = Nothing - , activityAudience = Audience recips [] [] [] [] [] - , activitySpecific = AcceptActivity Accept - { acceptObject = ObjURI hLocal luOffer - , acceptResult = - Just $ encodeRouteLocal $ ticketRoute ltkhid + , activitySummary = Nothing + , activityAudience = Audience recips [] [] [] [] [] + , activityFulfills = [] + , activitySpecific = AcceptActivity Accept + { acceptObject = + encodeRouteHome $ + PersonOutboxItemR personHash offerHash + , acceptResult = Just $ encodeRouteLocal ticketRoute } } - update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc] - return (doc, makeRecipientSet actors collections) --} + update acceptID [OutboxItemActivity =. persistJSONObjectFromDoc doc] + return doc {- verifyHosterRecip _ _ (Right _) = return () @@ -2949,7 +2943,7 @@ actorOutboxItem (LocalActorLoom l) = LoomOutboxItemR l offerDepC :: Entity Person - -> Maybe TextHtml + -> Maybe HTML -> Audience URIMode -> TicketDependency URIMode -> FedURI @@ -3211,7 +3205,7 @@ insertAcceptOnTicketStatus shrUser wi (WorkItemDetail _ ctx author) obiidResolve resolveC :: Entity Person - -> Maybe TextHtml + -> Maybe HTML -> Audience URIMode -> Resolve URIMode -> ExceptT Text Handler OutboxItemId @@ -3329,7 +3323,7 @@ resolveC (Entity pidUser personUser) summary audience (Resolve uObject) = do undoC :: Entity Person - -> Maybe TextHtml + -> Maybe HTML -> Audience URIMode -> Undo URIMode -> ExceptT Text Handler OutboxItemId @@ -3527,7 +3521,7 @@ pushCommitsC eperson summary push shrRepo rpRepo = do , activityActor = encodeRouteLocal $ SharerR shrUser , activityCapability = Nothing , activitySummary = - Just $ TextHtml $ TL.toStrict $ renderHtml summary + Just $ renderHTML summary , activityAudience = Audience aud [] [] [] [] [] , activitySpecific = PushActivity push } diff --git a/src/Vervis/Client.hs b/src/Vervis/Client.hs index 67e28b6..f1a3862 100644 --- a/src/Vervis/Client.hs +++ b/src/Vervis/Client.hs @@ -57,6 +57,7 @@ import qualified Data.Text.Lazy as TL import Development.PatchMediaType import Network.FedURI import Web.ActivityPub hiding (Follow, Ticket, Project (..), Repo, ActorLocal (..)) +import Web.Text import Yesod.ActivityPub import Yesod.FedURI import Yesod.Hashids @@ -603,7 +604,7 @@ createDeck => KeyHashid Person -> Text -> Text - -> m (Maybe TextHtml, Audience URIMode, AP.ActorDetail) + -> m (Maybe HTML, Audience URIMode, AP.ActorDetail) createDeck senderHash name desc = do encodeRouteHome <- getEncodeRouteHome @@ -629,7 +630,7 @@ createLoom -> Text -> Text -> KeyHashid Repo - -> m (Maybe TextHtml, Audience URIMode, AP.ActorDetail, NonEmpty FedURI) + -> m (Maybe HTML, Audience URIMode, AP.ActorDetail, NonEmpty FedURI) createLoom senderHash name desc repoHash = do encodeRouteHome <- getEncodeRouteHome @@ -659,7 +660,7 @@ createRepo => KeyHashid Person -> Text -> Text - -> m (Maybe TextHtml, Audience URIMode, AP.ActorDetail) + -> m (Maybe HTML, Audience URIMode, AP.ActorDetail) createRepo senderHash name desc = do encodeRouteHome <- getEncodeRouteHome diff --git a/src/Vervis/Data/Ticket.hs b/src/Vervis/Data/Ticket.hs new file mode 100644 index 0000000..f1ff7c3 --- /dev/null +++ b/src/Vervis/Data/Ticket.hs @@ -0,0 +1,196 @@ +{- This file is part of Vervis. + - + - Written in 2022 by fr33domlover . + - + - ♡ Copying is an act of love. Please copy, reuse and share. + - + - The author(s) have dedicated all copyright and related and neighboring + - rights to this software to the public domain worldwide. This software is + - distributed without any warranty. + - + - You should have received a copy of the CC0 Public Domain Dedication along + - with this software. If not, see + - . + -} + +module Vervis.Data.Ticket + ( Tip (..) + , Material (..) + , Merge (..) + , TrackerAndMerge (..) + , WorkItemOffer (..) + , checkOfferTicket + ) +where + +import Control.Monad +import Control.Monad.Trans.Except +import Data.Bifunctor +import Data.Foldable +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Text (Text) +import Data.Traversable + +import Development.PatchMediaType +import Network.FedURI +import Web.Text +import Yesod.ActivityPub +import Yesod.FedURI +import Yesod.Hashids + +import qualified Web.ActivityPub as AP + +import Control.Monad.Trans.Except.Local + +import Vervis.Foundation +import Vervis.FedURI +import Vervis.Model + +data Tip + = TipLocalRepo RepoId + | TipLocalBranch RepoId Text + | TipRemote FedURI + | TipRemoteBranch FedURI Text + +data Material = Material + { materialType :: PatchMediaType + , materialPatches :: NonEmpty Text + } + +data Merge = Merge + { mergeOrigin :: Maybe Tip + , mergeMaterial :: Maybe Material + , mergeTarget :: Tip + } + +data Tracker = TrackerDeck DeckId | TrackerLoom LoomId | TrackerRemote FedURI + deriving Eq + +data TrackerAndMerge = + TAM_Task DeckId | TAM_Merge LoomId Merge | TAM_Remote FedURI (Maybe Merge) + +data WorkItemOffer = WorkItemOffer + { wioAuthor :: Either PersonId FedURI + , wioTitle :: Text + , wioDesc :: HTML + , wioSource :: PandocMarkdown + , wioRest :: TrackerAndMerge + } + +checkAuthor :: FedURI -> ExceptT Text Handler (Either PersonId FedURI) +checkAuthor u@(ObjURI h lu) = do + hl <- hostIsLocal h + if hl + then do + route <- fromMaybeE (decodeRouteLocal lu) "Local author not a valid route" + case route of + PersonR personHash -> Left <$> decodeKeyHashidE personHash "Local author invalid person hash" + _ -> throwE "Local author not a person route" + else pure $ Right u + +checkPatch :: Host -> AP.Patch URIMode -> ExceptT Text Handler (Either PersonId FedURI, PatchMediaType, Text) +checkPatch h (AP.Patch mlocal attrib mpub typ content) = do + verifyNothingE mlocal "Patch has 'id'" + author <- checkAuthor $ ObjURI h attrib + verifyNothingE mpub "Patch has 'published'" + return (author, typ, content) + +checkBundle :: Host -> AP.Bundle URIMode -> ExceptT Text Handler (Either PersonId FedURI, Material) +checkBundle _ (AP.BundleHosted _ _) = throwE "Patches specified as URIs" +checkBundle h (AP.BundleOffer mlocal patches) = do + verifyNothingE mlocal "Bundle has 'id'" + (author, typ, content) :| rest <- traverse (checkPatch h) patches + let authors = map (\ (a, _, _) -> a) rest + typs = map (\ (_, t, _) -> t) rest + contents = map (\ (_, _, c) -> c) rest + unless (all (== author) authors) $ throwE "Different patch authors" + unless (all (== typ) typs) $ throwE "Different patch types" + return (author, Material typ (content :| contents)) + +checkTipURI :: FedURI -> ExceptT Text Handler (Either RepoId FedURI) +checkTipURI u@(ObjURI h lu) = do + hl <- hostIsLocal h + if hl + then Left <$> do + route <- fromMaybeE (decodeRouteLocal lu) "URI is local but isn't a valid route" + case route of + RepoR repoHash -> decodeKeyHashidE repoHash "URI is local repo route but repo hash is invalid" + _ -> throwE "URI is local route but not a repo route" + else pure $ Right u + +checkBranch :: Host -> AP.Branch URIMode -> ExceptT Text Handler (Either RepoId FedURI, Text) +checkBranch h (AP.Branch name _ luRepo) = + (,name) <$> nameExceptT "Branch repo" (checkTipURI $ ObjURI h luRepo) + +checkTip :: Either FedURI (Host, AP.Branch URIMode) -> ExceptT Text Handler Tip +checkTip (Left u) = either TipLocalRepo TipRemote <$> checkTipURI u +checkTip (Right (h, b)) = uncurry ($) . first (either TipLocalBranch TipRemoteBranch) <$> checkBranch h b + +checkMR + :: Host + -> AP.MergeRequest URIMode + -> ExceptT Text Handler + (Maybe Tip, Maybe (Either PersonId FedURI, Material), Tip) +checkMR h (AP.MergeRequest muOrigin target mbundle) = + (,,) + <$> traverse checkTip muOrigin + <*> (for mbundle $ \ bundle -> + case bundle of + Left _ -> throwE "MR bundle specified as a URI" + Right (h, b) -> checkBundle h b + ) + <*> checkTip (bimap (ObjURI h) (h,) target) + +checkTracker :: FedURI -> ExceptT Text Handler Tracker +checkTracker u@(ObjURI h lu) = do + hl <- hostIsLocal h + if hl + then do + route <- fromMaybeE (decodeRouteLocal lu) "Local tracker not a valid route" + case route of + DeckR deckHash -> TrackerDeck <$> decodeKeyHashidE deckHash "Local tracker invalid deck hash" + LoomR loomHash -> TrackerLoom <$> decodeKeyHashidE loomHash "Local tracker invalid loom hash" + _ -> throwE "Local tracker not a deck/loom route" + else pure $ TrackerRemote u + +checkTicket + :: Host + -> AP.Ticket URIMode + -> ExceptT Text Handler + ( Either PersonId FedURI + , Text, HTML, PandocMarkdown + , Maybe Tracker + , Maybe Merge + ) +checkTicket h (AP.Ticket mlocal attrib mpublished mupdated muContext summary content source muAssigned mresolved mmr) = do + verifyNothingE mlocal "Ticket with 'id'" + author <- checkAuthor $ ObjURI h attrib + verifyNothingE mpublished "Ticket with 'published'" + verifyNothingE mupdated "Ticket with 'updated'" + maybeTracker <- traverse checkTracker muContext + verifyNothingE muAssigned "Ticket has 'assignedTo'" + verifyNothingE mresolved "Ticket is resolved" + maybeMerge <- for mmr $ \ (h, mr) -> do + (maybeOriginTip, maybeAuthorAndBundle, targetTip) <- checkMR h mr + maybeBundle <- for maybeAuthorAndBundle $ \ (author', bundle) -> do + unless (author == author') $ + throwE "Ticket author and patch(es) author are different" + return bundle + return $ Merge maybeOriginTip maybeBundle targetTip + return (author, decodeEntities summary, content, source, maybeTracker, maybeMerge) + +checkTrackerAndMerge :: Tracker -> Maybe Merge -> ExceptT Text Handler TrackerAndMerge +checkTrackerAndMerge (TrackerDeck deckID) Nothing = pure $ TAM_Task deckID +checkTrackerAndMerge (TrackerDeck _) (Just _) = throwE "Deck & MR" +checkTrackerAndMerge (TrackerLoom _) Nothing = throwE "Loom & no MR" +checkTrackerAndMerge (TrackerLoom loomID) (Just merge) = pure $ TAM_Merge loomID merge +checkTrackerAndMerge (TrackerRemote uTracker) maybeMerge = pure $ TAM_Remote uTracker maybeMerge + +checkOfferTicket :: Host -> AP.Ticket URIMode -> FedURI -> ExceptT Text Handler WorkItemOffer +checkOfferTicket host ticket uTarget = do + target <- checkTracker uTarget + (author, title, desc, source, maybeTracker, maybeBundle) <- checkTicket host ticket + for_ maybeTracker $ \ tracker -> + unless (tracker == target) $ throwE "Offer target != ticket context" + tam <- checkTrackerAndMerge target maybeBundle + return $ WorkItemOffer author title desc source tam diff --git a/src/Vervis/Handler/Cloth.hs b/src/Vervis/Handler/Cloth.hs index 3d78ce8..58b254c 100644 --- a/src/Vervis/Handler/Cloth.hs +++ b/src/Vervis/Handler/Cloth.hs @@ -85,6 +85,7 @@ import Data.MediaType import Development.PatchMediaType import Network.FedURI import Web.ActivityPub hiding (Ticket (..), Patch (..), Bundle (..), Repo (..), ActorDetail (..)) +import Web.Text import Yesod.ActivityPub import Yesod.FedURI import Yesod.Hashids @@ -247,9 +248,9 @@ getClothR loomHash clothHash = do , AP.ticketUpdated = Nothing , AP.ticketContext = Just $ encodeRouteHome $ LoomR loomHash -- , AP.ticketName = Just $ "#" <> T.pack (show num) - , AP.ticketSummary = TextHtml $ ticketTitle ticket - , AP.ticketContent = TextHtml $ ticketDescription ticket - , AP.ticketSource = TextPandocMarkdown $ ticketSource ticket + , AP.ticketSummary = encodeEntities $ ticketTitle ticket + , AP.ticketContent = ticketDescription ticket + , AP.ticketSource = ticketSource ticket , AP.ticketAssignedTo = Nothing , AP.ticketResolved = let u (Left (actor, obiid)) = @@ -305,7 +306,7 @@ getClothR loomHash clothHash = do (justHere proposal) hashMessageKey <- handlerToWidget getEncodeKeyHashid let desc :: Widget - desc = toWidget $ preEscapedToMarkup $ ticketDescription ticket + desc = toWidget $ markupHTML $ ticketDescription ticket discuss = discussionW (return $ ticketDiscuss ticket) diff --git a/src/Vervis/Handler/Ticket.hs b/src/Vervis/Handler/Ticket.hs index e02d510..4bc4a3e 100644 --- a/src/Vervis/Handler/Ticket.hs +++ b/src/Vervis/Handler/Ticket.hs @@ -97,7 +97,7 @@ import Data.Time.Format (formatTime, defaultTimeLocale) import Data.Traversable (for) import Database.Persist import Network.HTTP.Types (StdMethod (DELETE, POST)) -import Text.Blaze.Html (Html, toHtml, preEscapedToHtml) +import Text.Blaze.Html (Html, toHtml) import Text.Blaze.Html.Renderer.Text import Text.HTML.SanitizeXSS import Yesod.Auth (requireAuthId, maybeAuthId) @@ -120,6 +120,7 @@ import Data.Aeson.Encode.Pretty.ToEncoding import Data.MediaType import Network.FedURI import Web.ActivityPub hiding (Ticket (..), Project, TicketDependency) +import Web.Text import Yesod.ActivityPub import Yesod.Auth.Unverified import Yesod.FedURI @@ -230,9 +231,9 @@ getTicketR deckHash ticketHash = do , AP.ticketUpdated = Nothing , AP.ticketContext = Just $ encodeRouteHome $ DeckR deckHash -- , AP.ticketName = Just $ "#" <> T.pack (show num) - , AP.ticketSummary = TextHtml $ ticketTitle ticket - , AP.ticketContent = TextHtml $ ticketDescription ticket - , AP.ticketSource = TextPandocMarkdown $ ticketSource ticket + , AP.ticketSummary = encodeEntities $ ticketTitle ticket + , AP.ticketContent = ticketDescription ticket + , AP.ticketSource = ticketSource ticket , AP.ticketAssignedTo = Nothing , AP.ticketResolved = let u (Left (actor, obiid)) = @@ -269,7 +270,7 @@ getTicketR deckHash ticketHash = do <*> getTicketClasses ticketID --wid hashMessageKey <- handlerToWidget getEncodeKeyHashid let desc :: Widget - desc = toWidget $ preEscapedToMarkup $ ticketDescription ticket + desc = toWidget $ markupHTML $ ticketDescription ticket discuss = discussionW (return $ ticketDiscuss ticket) @@ -1085,9 +1086,9 @@ getSharerTicketR shr talkhid = do ProjectR (sharerIdent s) (projectIdent j) Right (i, ro) -> ObjURI (instanceHost i) (remoteObjectIdent ro) - , AP.ticketSummary = TextHtml $ ticketTitle ticket - , AP.ticketContent = TextHtml $ ticketDescription ticket - , AP.ticketSource = TextPandocMarkdown $ ticketSource ticket + , AP.ticketSummary = encodeEntities $ ticketTitle ticket + , AP.ticketContent = ticketDescription ticket + , AP.ticketSource = ticketSource ticket , AP.ticketAssignedTo = encodeRouteHome . SharerR . sharerIdent <$> massignee , AP.ticketResolved = diff --git a/src/Vervis/Migration.hs b/src/Vervis/Migration.hs index 1b719de..719e8b2 100644 --- a/src/Vervis/Migration.hs +++ b/src/Vervis/Migration.hs @@ -62,7 +62,9 @@ import qualified Data.CaseInsensitive as CI import qualified Data.HashMap.Strict as M import qualified Data.Text as T import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Builder as TLB import qualified Database.Esqueleto as E +import qualified HTMLEntities.Decoder as HED import qualified Database.Persist.Schema as S import qualified Database.Persist.Schema.Types as ST @@ -2690,6 +2692,14 @@ changes hLocal ctx = , addFieldRefOptional "Repo" Nothing "loom" "Loom" -- 494 , addEntities model_494_mr_origin + -- 495 + , unchecked $ lift $ do + tickets <- selectList [] [] + for_ tickets $ \ (Entity ticketID ticket) -> do + let plain = + TL.toStrict . TLB.toLazyText . HED.htmlEncodedText $ + ticket495Title ticket + update ticketID [Ticket495Title =. plain] ] migrateDB diff --git a/src/Vervis/Migration/Model.hs b/src/Vervis/Migration/Model.hs index 14ad7ce..1d20b98 100644 --- a/src/Vervis/Migration/Model.hs +++ b/src/Vervis/Migration/Model.hs @@ -296,6 +296,7 @@ import Database.Persist.Schema.SQL () import Database.Persist.Schema.TH (makeEntitiesMigration) import Database.Persist.Sql (SqlBackend) import Text.Email.Validate (EmailAddress) +import Web.Text (HTML, PandocMarkdown) import Development.PatchMediaType import Development.PatchMediaType.Persist @@ -665,3 +666,6 @@ makeEntitiesMigration "486" model_494_mr_origin :: [Entity SqlBackend] model_494_mr_origin = $(schema "494_2022-09-17_mr_origin") + +makeEntitiesMigration "495" + $(modelFile "migrations/495_2022-09-21_ticket_title.model") diff --git a/src/Vervis/Model.hs b/src/Vervis/Model.hs index 0f593c3..9262342 100644 --- a/src/Vervis/Model.hs +++ b/src/Vervis/Model.hs @@ -39,6 +39,7 @@ import Development.PatchMediaType import Development.PatchMediaType.Persist import Network.FedURI import Web.ActivityPub (Doc, Activity) +import Web.Text (HTML, PandocMarkdown) import Vervis.FedURI import Vervis.Model.Group diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index cc2d9a3..92dc208 100644 --- a/src/Web/ActivityPub.hs +++ b/src/Web/ActivityPub.hs @@ -47,8 +47,6 @@ module Web.ActivityPub -- * Content objects , Note (..) , TicketDependency (..) - , TextHtml (..) - , TextPandocMarkdown (..) , PatchLocal (..) , Patch (..) , BundleLocal (..) @@ -100,6 +98,7 @@ module Web.ActivityPub , fetchAP , fetchAPID , fetchAPID' + , fetchTip , fetchRecipient , fetchResource , keyListedByActor @@ -161,6 +160,7 @@ import Development.PatchMediaType import Development.PatchMediaType.JSON import Network.FedURI import Network.HTTP.Digest +import Web.Text import Data.Aeson.Local @@ -902,16 +902,6 @@ instance ActivityPub TicketDependency where , relationshipUpdated = ticketDepUpdated td } -newtype TextHtml = TextHtml - { unTextHtml :: Text - } - deriving (FromJSON, ToJSON) - -newtype TextPandocMarkdown = TextPandocMarkdown - { unTextPandocMarkdown :: Text - } - deriving (FromJSON, ToJSON) - data PatchLocal = PatchLocal { patchId :: LocalURI , patchContext :: LocalURI @@ -1149,9 +1139,9 @@ data Ticket u = Ticket , ticketUpdated :: Maybe UTCTime , ticketContext :: Maybe (ObjURI u) -- , ticketName :: Maybe Text - , ticketSummary :: TextHtml - , ticketContent :: TextHtml - , ticketSource :: TextPandocMarkdown + , ticketSummary :: Escaped + , ticketContent :: HTML + , ticketSource :: PandocMarkdown , ticketAssignedTo :: Maybe (ObjURI u) , ticketResolved :: Maybe (Maybe (ObjURI u), Maybe UTCTime) , ticketAttachment :: Maybe (Authority u, MergeRequest u) @@ -1195,8 +1185,8 @@ instance ActivityPub Ticket where <*> o .:? "updated" <*> o .:? "context" -- <*> o .:? "name" - <*> (TextHtml . sanitizeBalance <$> o .: "summary") - <*> (TextHtml . sanitizeBalance <$> o .: "content") + <*> o .: "summary" + <*> o .: "content" <*> source .: "content" <*> o .:? "assignedTo" <*> pure mresolved @@ -1687,7 +1677,7 @@ data Activity u = Activity { activityId :: Maybe LocalURI , activityActor :: LocalURI , activityCapability :: Maybe (ObjURI u) - , activitySummary :: Maybe TextHtml + , activitySummary :: Maybe HTML , activityAudience :: Audience u , activityFulfills :: [ObjURI u] , activitySpecific :: SpecificActivity u @@ -1702,7 +1692,7 @@ instance ActivityPub Activity where <$> withAuthorityMaybeO a (o .:? "id") <*> pure actor <*> o .:? "capability" - <*> (fmap (TextHtml . sanitizeBalance) <$> o .:? "summary") + <*> o .:? "summary" <*> parseAudience o <*> o .:? "fulfills" .!= [] <*> do @@ -1961,6 +1951,18 @@ fetchAPID' m getId h lu = runExceptT $ do then return v else throwE Nothing +fetchTip :: (MonadIO m, UriMode u) => Manager -> Authority u -> LocalURI -> m (Either (Maybe APGetError) (Either (Repo u) (Branch u))) +fetchTip m h lu = runExceptT $ do + tip <- fmap toEither $ withExceptT Just $ fetchAP' m $ Left $ ObjURI h lu + bitraverse + (\ (Doc h' repo) -> + if h == h' && actorId (actorLocal $ repoActor repo) == lu + then return repo + else throwE Nothing + ) + (\ (Doc _ branch) -> pure branch) + tip + fetchRecipient :: (MonadIO m, UriMode u) => Manager -> Authority u -> LocalURI -> m (Either (Maybe APGetError) (Recipient u)) fetchRecipient m = fetchAPID' m getId where diff --git a/src/Web/Text.hs b/src/Web/Text.hs new file mode 100644 index 0000000..b8947ff --- /dev/null +++ b/src/Web/Text.hs @@ -0,0 +1,77 @@ +{- This file is part of Vervis. + - + - Written in 2022 by fr33domlover . + - + - ♡ Copying is an act of love. Please copy, reuse and share. + - + - The author(s) have dedicated all copyright and related and neighboring + - rights to this software to the public domain worldwide. This software is + - distributed without any warranty. + - + - You should have received a copy of the CC0 Public Domain Dedication along + - with this software. If not, see + - . + -} + +module Web.Text + ( HTML () + , PandocMarkdown () + , Escaped () + , renderHTML + , markupHTML + , encodeEntities + , decodeEntities + ) +where + +import Data.Aeson +import Data.Text (Text) +import Database.Persist +import Database.Persist.Sql +import HTMLEntities.Decoder +import Text.Blaze (preEscapedText) +import Text.Blaze.Html (Html) +import Text.Blaze.Html.Renderer.Text +import Text.HTML.SanitizeXSS + +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Builder as TLB +import qualified HTMLEntities.Text as HET + +newtype HTML = HTML { unHTML :: Text } + deriving (ToJSON, PersistField, PersistFieldSql) + +instance FromJSON HTML where + parseJSON = fmap (HTML . sanitizeBalance) . parseJSON + +newtype PandocMarkdown = PandocMarkdown { _unPandocMarkdown :: Text } + deriving (FromJSON, ToJSON, PersistField, PersistFieldSql) + +newtype Escaped = Escaped { unEscaped :: Text } + deriving (ToJSON, PersistField, PersistFieldSql) + +escape :: Text -> Text +escape = HET.text + +unescape :: Text -> Text +unescape = TL.toStrict . TLB.toLazyText . htmlEncodedText + +instance FromJSON Escaped where + parseJSON = + withText "Escaped" $ \ t -> + let decoded = unescape t + in if escape decoded == t + then return $ Escaped t + else fail "HTML contains more than just HTML-escaped plain text" + +renderHTML :: Html -> HTML +renderHTML = HTML . TL.toStrict . renderHtml + +markupHTML :: HTML -> Html +markupHTML = preEscapedText . unHTML + +encodeEntities :: Text -> Escaped +encodeEntities = Escaped . escape + +decodeEntities :: Escaped -> Text +decodeEntities = unescape . unEscaped diff --git a/templates/cloth/one.hamlet b/templates/cloth/one.hamlet index 6f9f71c..e9a6329 100644 --- a/templates/cloth/one.hamlet +++ b/templates/cloth/one.hamlet @@ -13,7 +13,7 @@ $# You should have received a copy of the CC0 Public Domain Dedication along $# with this software. If not, see $# . -

#{preEscapedToHtml $ ticketTitle ticket} +

#{ticketTitle ticket}
Created on #{showDate $ ticketCreated ticket} by diff --git a/templates/ticket/one.hamlet b/templates/ticket/one.hamlet index 9ebecff..8c4be11 100644 --- a/templates/ticket/one.hamlet +++ b/templates/ticket/one.hamlet @@ -13,7 +13,7 @@ $# You should have received a copy of the CC0 Public Domain Dedication along $# with this software. If not, see $# . -

#{preEscapedToHtml $ ticketTitle ticket} +

#{ticketTitle ticket}
Created on #{showDate $ ticketCreated ticket} by diff --git a/th/models b/th/models index 3ce6b81..7bca97f 100644 --- a/th/models +++ b/th/models @@ -415,9 +415,9 @@ TicketParamClass Ticket number Int Maybe created UTCTime - title Text -- HTML - source Text -- Pandoc Markdown - description Text -- HTML + title Text + source PandocMarkdown + description HTML status TicketStatus discuss DiscussionId followers FollowerSetId diff --git a/vervis.cabal b/vervis.cabal index 89383ce..b04bd7e 100644 --- a/vervis.cabal +++ b/vervis.cabal @@ -108,6 +108,7 @@ library Web.ActivityAccess Web.ActivityPub -- Web.Capability + Web.Text Web.Hashids.Local Web.PathPieces.Local Yesod.ActivityPub @@ -140,6 +141,7 @@ library Vervis.Data.Actor Vervis.Data.Collab + Vervis.Data.Ticket Vervis.Delivery Vervis.Discussion @@ -256,6 +258,7 @@ library ViewPatterns TupleSections RecordWildCards + LambdaCase build-depends: aeson -- For activity JSOn display in /inbox test page @@ -324,6 +327,7 @@ library -- for source file highlighting , highlighter2 , http-client-signature + , html-entities , http-signature , git , hit-graph