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

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

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

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|
                     <p>
@@ -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|
                         <p>
@@ -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
+offerTicketC (Entity senderPersonID senderPerson) senderActor summary audience ticket uTarget = do
-    error "offerTicketC temporarily disabled"
 
-
+    -- Check input
-{-
+    (title, desc, source, tam) <- do
-    senderHash <- encodeKeyHashid pidUser
+        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)
-
-
-    (target, title, desc, source) <- checkOfferTicket shrUser ticket uTarget
     ParsedAudience localRecips remoteRecips blinded fwdHosts <- do
         mrecips <- parseAudience audience
         fromMaybeE mrecips "Offer Ticket with no recipients"
-    federation <- asksSite $ appFederation . appSettings
+    checkFederation remoteRecips
-    unless (federation || null remoteRecips) $
+
-        throwE "Federation disabled, but remote recipients specified"
+    -- Verify that the target tracker is addressed by the Offer
-    verifyProjectRecip target localRecips
+    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]
-            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 $ 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
-    where
 
-
+    -- 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
-    checkOfferTicket
+                        (vcs, raid, mb) <- withExceptT (T.pack . show) $ httpGetRemoteTip uOrigin
-        :: ShrIdent
+                        return (vcs, raid, first Just <$> mb)
-        -> AP.Ticket URIMode
+                    TipRemoteBranch uRepo branch -> Right <$> do
-        -> FedURI
+                        (vcs, raid) <- withExceptT (T.pack . show) $ httpGetRemoteRepo uRepo
-        -> ExceptT Text Handler
+                        return (vcs, raid, Just (Nothing, branch))
-            ( Either WorkItemTarget (Host, LocalURI, Maybe (Maybe LocalURI, PatchMediaType, NonEmpty Text))
+                originOrBundle <-
-            , TextHtml
-            , TextHtml
-            , TextPandocMarkdown
-            )
-    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)
-        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
-
-
-
-
-
-
-
-
-
-        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)
+                        (align maybeOrigin maybeBundle)
-                                        "MR target is local but isn't a valid route"
+                        "MR provides neither origin nor patches"
-                                case route of
+                (targetRepoID, maybeTargetBranch) <-
-                                    RepoR shr rp -> return (shr, rp, Nothing)
+                    case targetTip of
-                                    RepoBranchR shr rp b -> return (shr, rp, Just b)
+                        TipLocalRepo repoID -> pure (repoID, Nothing)
-                                    _ ->
+                        TipLocalBranch repoID branch -> pure (repoID, Just branch)
-                                        throwE
+                        _ -> throwE "Offer target is a local loom but MR target is a remote repo (Looms serve only local repos)"
-                                            "MR target is a valid local route, but isn't a \
+                return $ Just $ Right (loomID, originOrBundle, targetRepoID, maybeTargetBranch)
-                                            \repo or branch route"
+            TAM_Remote _ _ -> pure Nothing
-                            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
+    (offerID, deliverHttpOffer, maybeDeliverHttpAccept) <- runDBExcept $ do
-        hLocal <- asksSite siteInstanceHost
+
-        obiid <- insertEmptyOutboxItem obid now
+        -- 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 (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" 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
+
+    httpGetRemoteTip
+        :: FedURI
+        -> ExceptT Result Handler
+            ( VersionControlSystem
+            , RemoteActorId
+            , Maybe (LocalURI, Text)
+            )
+    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
+        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)
+
+    insertOfferToOutbox senderHash blinded offerID = do
         encodeRouteLocal <- getEncodeRouteLocal
-        obikhid <- encodeKeyHashid obiid
+        hLocal <- asksSite siteInstanceHost
-        let luAct = encodeRouteLocal $ SharerOutboxItemR shrUser obikhid
+        offerHash <- encodeKeyHashid offerID
-            doc = Doc hLocal Activity
+        let doc = Doc hLocal Activity
-                { activityId       = Just luAct
+                { activityId         =
-                , activityActor    = encodeRouteLocal $ SharerR shrUser
+                    Just $ encodeRouteLocal $
+                        PersonOutboxItemR senderHash offerHash
+                , activityActor      = encodeRouteLocal $ PersonR senderHash
                 , activityCapability = Nothing
                 , activitySummary    = summary
                 , activityAudience   = blinded
+                , activityFulfills   = []
                 , activitySpecific   =
                     OfferActivity $ Offer (OfferTicket ticket) uTarget
                 }
-        update obiid [OutboxItemActivity =. persistJSONObjectFromDoc doc]
+        update offerID [OutboxItemActivity =. persistJSONObjectFromDoc doc]
-        return (obiid, doc, luAct)
+        return doc
-    insertTicket pidAuthor now title desc source insertTXL obiid obiidAccept = do
+
+    insertTicket now title desc source offerID acceptID = do
         did <- insert Discussion
         fsid <- insert FollowerSet
         tid <- insert Ticket
             { ticketNumber      = Nothing
             , ticketCreated     = now
-            , ticketTitle       = unTextHtml title
+            , ticketTitle       = title
-            , ticketSource      = unTextPandocMarkdown source
+            , ticketSource      = source
-            , ticketDescription = unTextHtml desc
+            , ticketDescription = desc
-            , ticketAssignee    = Nothing
             , ticketStatus      = TSNew
+            , ticketDiscuss     = did
+            , ticketFollowers   = fsid
+            , ticketAccept      = acceptID
             }
-        ltid <- insert LocalTicket
+        insert_ TicketAuthorLocal
-            { localTicketTicket    = tid
+            { ticketAuthorLocalTicket = tid
-            , localTicketDiscuss   = did
+            , ticketAuthorLocalAuthor = senderPersonID
-            , localTicketFollowers = fsid
+            , ticketAuthorLocalOpen   = offerID
             }
-        tclid <- insert TicketContextLocal
+        return tid
-            { ticketContextLocalTicket = tid
+
-            , ticketContextLocalAccept = obiidAccept
+    insertTask deckID ticketID = do
-            }
+        ticketDeckID <- insert $ TicketDeck ticketID deckID
-        insertTXL tclid
+        TicketR <$> encodeKeyHashid deckID <*> encodeKeyHashid ticketDeckID
-        talid <- insert TicketAuthorLocal
+
-            { ticketAuthorLocalTicket = ltid
+    insertMerge
-            , ticketAuthorLocalAuthor = pidAuthor
+        :: UTCTime
-            , ticketAuthorLocalOpen   = obiid
+        -> LoomId
-            }
+        -> TicketId
-        insert_ TicketUnderProject
+        -> Maybe Text
-            { ticketUnderProjectProject = tclid
+        -> These
-            , ticketUnderProjectAuthor  = talid
+            (Either
-            }
+                (RepoId, VersionControlSystem, Maybe Text)
-        return (tid, ltid)
+                (VersionControlSystem, RemoteActorId, Maybe (Maybe LocalURI, Text))
-    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
             )
+            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
+        offerHash <- encodeKeyHashid offerID
-        ltkhid <- encodeKeyHashid ltid
+        acceptHash <- encodeKeyHashid acceptID
-        let actors = [LocalActorSharer shrUser]
+        let recips =
-            recips =
                 map encodeRouteHome $
                         map renderLocalActor actors ++
-                    map renderLocalPersonCollection collections
+                        map renderLocalStage stages
             doc = Doc hLocal Activity
                 { activityId         =
-                    Just $ encodeRouteLocal $ outboxItemRoute obikhidAccept
+                    Just $ encodeRouteLocal $
-                , activityActor    = encodeRouteLocal projectRoute
+                        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 [] [] [] [] []
+                , activityFulfills   = []
                 , activitySpecific   = AcceptActivity Accept
-                    { acceptObject = ObjURI hLocal luOffer
+                    { acceptObject   =
-                    , acceptResult =
+                        encodeRouteHome $
-                        Just $ encodeRouteLocal $ ticketRoute ltkhid
+                            PersonOutboxItemR personHash offerHash
+                    , acceptResult   = Just $ encodeRouteLocal ticketRoute
                     }
                 }
-        update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc]
+        update acceptID [OutboxItemActivity =. persistJSONObjectFromDoc doc]
-        return (doc, makeRecipientSet actors collections)
+        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
                 }

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
 

src/Vervis/Data/Ticket.hs

@@ -0,0 +1,196 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2022 by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ 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
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+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

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.ticketSummary      = encodeEntities $ ticketTitle ticket
-            , AP.ticketContent      = TextHtml $ ticketDescription ticket
+            , AP.ticketContent      = ticketDescription ticket
-            , AP.ticketSource       = TextPandocMarkdown $ ticketSource 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)

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.ticketSummary      = encodeEntities $ ticketTitle ticket
-            , AP.ticketContent      = TextHtml $ ticketDescription ticket
+            , AP.ticketContent      = ticketDescription ticket
-            , AP.ticketSource       = TextPandocMarkdown $ ticketSource 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.ticketSummary      = encodeEntities $ ticketTitle ticket
-            , AP.ticketContent      = TextHtml $ ticketDescription ticket
+            , AP.ticketContent      = ticketDescription ticket
-            , AP.ticketSource       = TextPandocMarkdown $ ticketSource ticket
+            , AP.ticketSource       = ticketSource ticket
             , AP.ticketAssignedTo   =
                 encodeRouteHome . SharerR . sharerIdent <$> massignee
             , AP.ticketResolved     =

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

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

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

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
+    , ticketSummary      :: Escaped
-    , ticketContent      :: TextHtml
+    , ticketContent      :: HTML
-    , ticketSource       :: TextPandocMarkdown
+    , 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")
+                <*> o .: "summary"
-                <*> (TextHtml . sanitizeBalance <$> o .: "content")
+                <*> 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

src/Web/Text.hs

@@ -0,0 +1,77 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2022 by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ 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
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+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

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
 $# <http://creativecommons.org/publicdomain/zero/1.0/>.
 
-<h2>#{preEscapedToHtml $ ticketTitle ticket}
+<h2>#{ticketTitle ticket}
 
 <div>
   Created on #{showDate $ ticketCreated ticket} by

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
 $# <http://creativecommons.org/publicdomain/zero/1.0/>.
 
-<h2>#{preEscapedToHtml $ ticketTitle ticket}
+<h2>#{ticketTitle ticket}
 
 <div>
   Created on #{showDate $ ticketCreated ticket} by

th/models

@@ -415,9 +415,9 @@ TicketParamClass
 Ticket
     number      Int           Maybe
     created     UTCTime
-    title       Text                -- HTML
+    title       Text
-    source      Text                -- Pandoc Markdown
+    source      PandocMarkdown
-    description Text                -- HTML
+    description HTML
     status      TicketStatus
     discuss     DiscussionId
     followers   FollowerSetId

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