@@ -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 #{preEscapedToHtml $ ticketTitle ticket}
+
#{ticketTitle ticket}
#{preEscapedToHtml $ ticketTitle ticket}
+
#{ticketTitle ticket}