NOTE: Federation is disabled on this instance!
You can test federation between the following instances:forge.angeley.es
code.angeley.es
By | fr33domlover |
At | 2020-07-22 |
Title | C2S: createTicketC: Allow to submit MRs i.e. Ticket with a Patch attached |
Description |
Edit file config/models 0 → 0
+ | 418 | -- For MRs it may be either a remote repo or |
|
+ | 419 | -- a branch of it |
|
… | … | … | … |
Edit file src/Vervis/API.hs 0 → 0
- | 492 | verifyProjectRecipOld (Right _) _ = return () |
|
- | 493 | verifyProjectRecipOld (Left (shr, prj)) localRecips = |
|
- | 494 | fromMaybeE verify "Local context project isn't listed as a recipient" |
|
- | 495 | where |
|
- | 496 | verify = do |
|
- | 497 | sharerSet <- lookup shr localRecips |
|
- | 498 | projectSet <- lookup prj $ localRecipProjectRelated sharerSet |
|
- | 499 | guard $ localRecipProject $ localRecipProjectDirect projectSet |
|
- | 500 | ||
… | … | … | … |
- | 521 | ticketData@(uContext, title, desc, source, uTarget) <- checkTicket shrUser ticket muTarget |
|
- | 522 | context <- parseTicketContext uContext |
|
+ | 512 | (context, title, desc, source) <- checkCreateTicket shrUser ticket muTarget |
|
- | 526 | verifyProjectRecipOld context localRecips |
|
- | 527 | tracker <- fetchTracker context uTarget |
|
+ | 516 | verifyProjectRecip context localRecips |
|
+ | 517 | tracker <- bitraverse pure fetchTracker context |
|
- | 532 | talid <- lift $ insertTicket now pidUser title desc source obiidCreate project |
|
- | 533 | docCreate <- lift $ insertCreateToOutbox shrUser blinded ticketData now obiidCreate talid |
|
+ | 522 | (talid, mptid) <- lift $ insertTicket now pidUser title desc source obiidCreate project |
|
+ | 523 | docCreate <- lift $ insertCreateToOutbox shrUser blinded context title desc source now obiidCreate talid mptid |
|
- | 536 | case tracker of |
|
- | 537 | Left (shr, prj) -> |
|
+ | 526 | case context of |
|
+ | 527 | Left (WTTProject shr prj) -> |
|
+ | 535 | Left (WTTRepo shr rp _ _ _) -> |
|
+ | 536 | makeRecipientSet |
|
+ | 537 | [ LocalActorRepo shr rp |
|
+ | 538 | ] |
|
+ | 539 | [ LocalPersonCollectionSharerFollowers shrUser |
|
+ | 540 | , LocalPersonCollectionRepoTeam shr rp |
|
+ | 541 | , LocalPersonCollectionRepoFollowers shr rp |
|
+ | 542 | ] |
|
… | … | … | … |
- | 557 | moreRemoteRecips <- lift $ deliverLocal' True (LocalActorSharer shrUser) (personInbox personUser) obiidCreate $ localRecipSieve sieve False localRecips |
|
+ | 555 | moreRemoteRecips <- |
|
+ | 556 | lift $ |
|
+ | 557 | deliverLocal' True (LocalActorSharer shrUser) (personInbox personUser) obiidCreate $ |
|
+ | 558 | localRecipSieve sieve False localRecips |
|
- | 565 | Left proj@(shr, Entity _ j, obiidAccept) -> Just <$> do |
|
- | 566 | let prj = projectIdent j |
|
- | 567 | recipsA = |
|
+ | 566 | Left proj@(shr, ent, obiidAccept) -> Just <$> do |
|
+ | 567 | let recipsA = |
|
- | 569 | recipsC = |
|
- | 570 | [ LocalPersonCollectionProjectTeam shr prj |
|
- | 571 | , LocalPersonCollectionProjectFollowers shr prj |
|
- | 572 | , LocalPersonCollectionSharerFollowers shrUser |
|
- | 573 | ] |
|
+ | 569 | (recipsC, ibid, actor) = |
|
+ | 570 | case ent of |
|
+ | 571 | Left (Entity _ j) -> |
|
+ | 572 | let prj = projectIdent j |
|
+ | 573 | in ( [ LocalPersonCollectionProjectTeam shr prj |
|
+ | 574 | , LocalPersonCollectionProjectFollowers shr prj |
|
+ | 575 | , LocalPersonCollectionSharerFollowers shrUser |
|
+ | 576 | ] |
|
+ | 577 | , projectInbox j |
|
+ | 578 | , LocalActorProject shr prj |
|
+ | 579 | ) |
|
+ | 580 | Right (Entity _ r, _, _) -> |
|
+ | 581 | let rp = repoIdent r |
|
+ | 582 | in ( [ LocalPersonCollectionRepoTeam shr rp |
|
+ | 583 | , LocalPersonCollectionRepoFollowers shr rp |
|
+ | 584 | , LocalPersonCollectionSharerFollowers shrUser |
|
+ | 585 | ] |
|
+ | 586 | , repoInbox r |
|
+ | 587 | , LocalActorRepo shr rp |
|
+ | 588 | ) |
|
… | … | … | … |
- | 590 | recips <- lift $ deliverLocal' True (LocalActorProject shr prj) (projectInbox j) obiidAccept $ makeRecipientSet recipsA recipsC |
|
+ | 605 | recips <- |
|
+ | 606 | lift $ |
|
+ | 607 | deliverLocal' True actor ibid obiidAccept $ |
|
+ | 608 | makeRecipientSet recipsA recipsC |
|
… | … | … | … |
- | 604 | checkTicket shr (AP.Ticket mlocal luAttrib mpublished mupdated mcontext summary content source massigned resolved mmr) mtarget = do |
|
- | 605 | verifyNothingE mlocal "Ticket with 'id'" |
|
- | 606 | encodeRouteLocal <- getEncodeRouteLocal |
|
- | 607 | unless (encodeRouteLocal (SharerR shr) == luAttrib) $ |
|
- | 608 | throwE "Ticket attributed to someone else" |
|
- | 609 | verifyNothingE mpublished "Ticket with 'published'" |
|
- | 610 | verifyNothingE mupdated "Ticket with 'updated'" |
|
- | 611 | context <- fromMaybeE mcontext "Ticket without 'context'" |
|
- | 612 | verifyNothingE massigned "Ticket with 'assignedTo'" |
|
- | 613 | when resolved $ throwE "Ticket resolved" |
|
- | 614 | target <- fromMaybeE mtarget "Create Ticket without 'target'" |
|
- | 615 | verifyNothingE mmr "Ticket with 'attachment'" |
|
- | 616 | return (context, summary, content, source, target) |
|
- | 617 | ||
- | 618 | parseTicketContext :: (MonadSite m, SiteEnv m ~ App) => FedURI -> ExceptT Text m (Either (ShrIdent, PrjIdent) FedURI) |
|
- | 619 | parseTicketContext u@(ObjURI h lu) = do |
|
- | 620 | hl <- hostIsLocal h |
|
- | 621 | if hl |
|
- | 622 | then Left <$> do |
|
- | 623 | route <- fromMaybeE (decodeRouteLocal lu) "Ticket context isn't a valid route" |
|
- | 624 | case route of |
|
- | 625 | ProjectR shr prj -> return (shr, prj) |
|
- | 626 | _ -> throwE "Ticket context isn't a project route" |
|
- | 627 | else return $ Right u |
|
- | 628 | ||
- | 629 | fetchTracker c u@(ObjURI h lu) = do |
|
- | 630 | hl <- hostIsLocal h |
|
- | 631 | case (hl, c) of |
|
- | 632 | (True, Left (shr, prj)) -> Left <$> do |
|
- | 633 | encodeRouteLocal <- getEncodeRouteLocal |
|
- | 634 | unless (encodeRouteLocal (ProjectR shr prj) == lu) $ |
|
- | 635 | throwE "Local context and target mismatch" |
|
- | 636 | return (shr, prj) |
|
- | 637 | (True, Right _) -> throwE "context and target different host" |
|
- | 638 | (False, Left _) -> throwE "context and target different host" |
|
- | 639 | (False, Right (ObjURI h' lu')) -> Right <$> do |
|
- | 640 | unless (h == h') $ throwE "context and target different host" |
|
- | 641 | (iid, era) <- do |
|
- | 642 | iid <- lift $ runDB $ either entityKey id <$> insertBy' (Instance h) |
|
- | 643 | result <- lift $ fetchRemoteActor iid h lu |
|
- | 644 | case result of |
|
- | 645 | Left e -> throwE $ T.pack $ displayException e |
|
- | 646 | Right (Left e) -> throwE $ T.pack $ show e |
|
- | 647 | Right (Right mera) -> do |
|
- | 648 | era <- fromMaybeE mera "target found to be a collection, not an actor" |
|
- | 649 | return (iid, era) |
|
- | 650 | return (iid, era, if lu == lu' then Nothing else Just lu') |
|
- | 651 | ||
- | 652 | prepareProject now (Left (shr, prj)) = Left <$> do |
|
+ | 622 | checkCreateTicket |
|
+ | 623 | :: ShrIdent |
|
+ | 624 | -> AP.Ticket URIMode |
|
+ | 625 | -> Maybe FedURI |
|
+ | 626 | -> ExceptT Text Handler |
|
+ | 627 | ( Either |
|
+ | 628 | WorkItemTarget |
|
+ | 629 | ( Host |
|
+ | 630 | , LocalURI |
|
+ | 631 | , LocalURI |
|
+ | 632 | , Maybe (Maybe LocalURI, PatchType, Text) |
|
+ | 633 | ) |
|
+ | 634 | , TextHtml |
|
+ | 635 | , TextHtml |
|
+ | 636 | , TextPandocMarkdown |
|
+ | 637 | ) |
|
+ | 638 | checkCreateTicket shr ticket muTarget = do |
|
+ | 639 | uTarget <- fromMaybeE muTarget "Create Ticket without 'target'" |
|
+ | 640 | target <- checkTracker "Create target" uTarget |
|
+ | 641 | (context, summary, content, source) <- checkTicket ticket |
|
+ | 642 | item <- checkTargetAndContext target context |
|
+ | 643 | return (item, summary, content, source) |
|
+ | 644 | where |
|
+ | 645 | checkTracker |
|
+ | 646 | :: Text |
|
+ | 647 | -> FedURI |
|
+ | 648 | -> ExceptT Text Handler |
|
+ | 649 | (Either |
|
+ | 650 | (Either (ShrIdent, PrjIdent) (ShrIdent, RpIdent)) |
|
+ | 651 | FedURI |
|
+ | 652 | ) |
|
+ | 653 | checkTracker name u@(ObjURI h lu) = do |
|
+ | 654 | hl <- hostIsLocal h |
|
+ | 655 | if hl |
|
+ | 656 | then Left <$> do |
|
+ | 657 | route <- |
|
+ | 658 | fromMaybeE |
|
+ | 659 | (decodeRouteLocal lu) |
|
+ | 660 | (name <> " is local but isn't a valid route") |
|
+ | 661 | case route of |
|
+ | 662 | ProjectR shr prj -> return $ Left (shr, prj) |
|
+ | 663 | RepoR shr rp -> return $ Right (shr, rp) |
|
+ | 664 | _ -> |
|
+ | 665 | throwE $ |
|
+ | 666 | name <> |
|
+ | 667 | " is a valid local route, but isn't a \ |
|
+ | 668 | \project/repo route" |
|
+ | 669 | else return $ Right u |
|
+ | 670 | checkTicket |
|
+ | 671 | :: AP.Ticket URIMode |
|
+ | 672 | -> ExceptT Text Handler |
|
+ | 673 | ( Either WorkItemTarget (Host, LocalURI, Maybe (Maybe LocalURI, PatchType, Text)) |
|
+ | 674 | , TextHtml |
|
+ | 675 | , TextHtml |
|
+ | 676 | , TextPandocMarkdown |
|
+ | 677 | ) |
|
+ | 678 | checkTicket (AP.Ticket mlocal attrib mpublished mupdated muContext summary |
|
+ | 679 | content source muAssigned resolved mmr) = do |
|
+ | 680 | verifyNothingE mlocal "Ticket with 'id'" |
|
+ | 681 | encodeRouteLocal <- getEncodeRouteLocal |
|
+ | 682 | unless (encodeRouteLocal (SharerR shr) == attrib) $ |
|
+ | 683 | throwE "Ticket attributed to someone else" |
|
+ | 684 | verifyNothingE mpublished "Ticket with 'published'" |
|
+ | 685 | verifyNothingE mupdated "Ticket with 'updated'" |
|
+ | 686 | uContext <- fromMaybeE muContext "Ticket without 'context'" |
|
+ | 687 | context <- checkTracker "Ticket context" uContext |
|
+ | 688 | verifyNothingE muAssigned "Ticket with 'assignedTo'" |
|
+ | 689 | when resolved $ throwE "Ticket resolved" |
|
+ | 690 | mmr' <- traverse (uncurry checkMR) mmr |
|
+ | 691 | context' <- matchContextAndMR context mmr' |
|
+ | 692 | return (context', summary, content, source) |
|
+ | 693 | where |
|
+ | 694 | checkMR |
|
+ | 695 | :: Host |
|
+ | 696 | -> MergeRequest URIMode |
|
+ | 697 | -> ExceptT Text Handler |
|
+ | 698 | ( Either (ShrIdent, RpIdent, Maybe Text) FedURI |
|
+ | 699 | , PatchType |
|
+ | 700 | , Text |
|
+ | 701 | ) |
|
+ | 702 | checkMR h (MergeRequest muOrigin luTarget epatch) = do |
|
+ | 703 | verifyNothingE muOrigin "MR with 'origin'" |
|
+ | 704 | branch <- checkBranch h luTarget |
|
+ | 705 | (typ, content) <- |
|
+ | 706 | case epatch of |
|
+ | 707 | Left _ -> throwE "MR patch specified as a URI" |
|
+ | 708 | Right (hPatch, patch) -> checkPatch hPatch patch |
|
+ | 709 | return (branch, typ, content) |
|
+ | 710 | where |
|
+ | 711 | checkBranch |
|
+ | 712 | :: Host |
|
+ | 713 | -> LocalURI |
|
+ | 714 | -> ExceptT Text Handler |
|
+ | 715 | (Either (ShrIdent, RpIdent, Maybe Text) FedURI) |
|
+ | 716 | checkBranch h lu = do |
|
+ | 717 | hl <- hostIsLocal h |
|
+ | 718 | if hl |
|
+ | 719 | then Left <$> do |
|
+ | 720 | route <- |
|
+ | 721 | fromMaybeE |
|
+ | 722 | (decodeRouteLocal lu) |
|
+ | 723 | "MR target is local but isn't a valid route" |
|
+ | 724 | case route of |
|
+ | 725 | RepoR shr rp -> return (shr, rp, Nothing) |
|
+ | 726 | RepoBranchR shr rp b -> return (shr, rp, Just b) |
|
+ | 727 | _ -> |
|
+ | 728 | throwE |
|
+ | 729 | "MR target is a valid local route, but isn't a \ |
|
+ | 730 | \repo or branch route" |
|
+ | 731 | else return $ Right $ ObjURI h lu |
|
+ | 732 | checkPatch |
|
+ | 733 | :: Host |
|
+ | 734 | -> AP.Patch URIMode |
|
+ | 735 | -> ExceptT Text Handler |
|
+ | 736 | ( PatchType |
|
+ | 737 | , Text |
|
+ | 738 | ) |
|
+ | 739 | checkPatch h (AP.Patch mlocal attrib mpub typ content) = do |
|
+ | 740 | encodeRouteLocal <- getEncodeRouteLocal |
|
+ | 741 | verifyHostLocal h "Patch attributed to remote user" |
|
+ | 742 | verifyNothingE mlocal "Patch with 'id'" |
|
+ | 743 | unless (encodeRouteLocal (SharerR shr) == attrib) $ |
|
+ | 744 | throwE "Ticket and Patch attrib mismatch" |
|
+ | 745 | verifyNothingE mpub "Patch has 'published'" |
|
+ | 746 | return (typ, content) |
|
+ | 747 | matchContextAndMR |
|
+ | 748 | :: Either |
|
+ | 749 | (Either (ShrIdent, PrjIdent) (ShrIdent, RpIdent)) |
|
+ | 750 | FedURI |
|
+ | 751 | -> Maybe |
|
+ | 752 | ( Either (ShrIdent, RpIdent, Maybe Text) FedURI |
|
+ | 753 | , PatchType |
|
+ | 754 | , Text |
|
+ | 755 | ) |
|
+ | 756 | -> ExceptT Text Handler |
|
+ | 757 | (Either |
|
+ | 758 | WorkItemTarget |
|
+ | 759 | ( Host |
|
+ | 760 | , LocalURI |
|
+ | 761 | , Maybe (Maybe LocalURI, PatchType, Text) |
|
+ | 762 | ) |
|
+ | 763 | ) |
|
+ | 764 | matchContextAndMR (Left (Left (shr, prj))) Nothing = return $ Left $ WTTProject shr prj |
|
+ | 765 | matchContextAndMR (Left (Left (shr, prj))) (Just _) = throwE "Patch offered to project" |
|
+ | 766 | matchContextAndMR (Left (Right (shr, rp))) Nothing = throwE "Issue offered to repo" |
|
+ | 767 | matchContextAndMR (Left (Right (shr, rp))) (Just (branch, typ, content)) = do |
|
+ | 768 | branch' <- |
|
+ | 769 | case branch of |
|
+ | 770 | Left (shr', rp', mb) | shr == shr' && rp == rp' -> return mb |
|
+ | 771 | _ -> throwE "MR target repo/branch and Ticket context repo mismatch" |
|
+ | 772 | let vcs = typ2vcs typ |
|
+ | 773 | case vcs of |
|
+ | 774 | VCSDarcs -> |
|
+ | 775 | unless (isNothing branch') $ |
|
+ | 776 | throwE "Darcs MR specifies a branch" |
|
+ | 777 | VCSGit -> |
|
+ | 778 | unless (isJust branch') $ |
|
+ | 779 | throwE "Git MR doesn't specify the branch" |
|
+ | 780 | return $ Left $ WTTRepo shr rp branch' vcs content |
|
+ | 781 | where |
|
+ | 782 | typ2vcs PatchTypeDarcs = VCSDarcs |
|
+ | 783 | matchContextAndMR (Right (ObjURI h lu)) Nothing = return $ Right (h, lu, Nothing) |
|
+ | 784 | matchContextAndMR (Right (ObjURI h lu)) (Just (branch, typ, content)) = do |
|
+ | 785 | luBranch <- |
|
+ | 786 | case branch of |
|
+ | 787 | Right (ObjURI h' lu') | h == h' -> return lu |
|
+ | 788 | _ -> throwE "MR target repo/branch and Ticket context repo mismatch" |
|
+ | 789 | let patch = |
|
+ | 790 | ( if lu == luBranch then Nothing else Just luBranch |
|
+ | 791 | , typ |
|
+ | 792 | , content |
|
+ | 793 | ) |
|
+ | 794 | return $ Right (h, lu, Just patch) |
|
+ | 795 | checkTargetAndContext |
|
+ | 796 | :: Either |
|
+ | 797 | (Either (ShrIdent, PrjIdent) (ShrIdent, RpIdent)) |
|
+ | 798 | FedURI |
|
+ | 799 | -> Either |
|
+ | 800 | WorkItemTarget |
|
+ | 801 | (Host, LocalURI, Maybe (Maybe LocalURI, PatchType, Text)) |
|
+ | 802 | -> ExceptT Text Handler |
|
+ | 803 | (Either |
|
+ | 804 | WorkItemTarget |
|
+ | 805 | ( Host |
|
+ | 806 | , LocalURI |
|
+ | 807 | , LocalURI |
|
+ | 808 | , Maybe (Maybe LocalURI, PatchType, Text) |
|
+ | 809 | ) |
|
+ | 810 | ) |
|
+ | 811 | checkTargetAndContext (Left _) (Right _) = |
|
+ | 812 | throwE "Create target is local but ticket context is remote" |
|
+ | 813 | checkTargetAndContext (Right _) (Left _) = |
|
+ | 814 | throwE "Create target is remote but ticket context is local" |
|
+ | 815 | checkTargetAndContext (Right (ObjURI hTarget luTarget)) (Right (hContext, luContext, mpatch)) = |
|
+ | 816 | if hTarget == hContext |
|
+ | 817 | then return $ Right (hContext, luTarget, luContext, mpatch) |
|
+ | 818 | else throwE "Create target and ticket context on different \ |
|
+ | 819 | \remote hosts" |
|
+ | 820 | checkTargetAndContext (Left proj) (Left wit) = |
|
+ | 821 | case (proj, wit) of |
|
+ | 822 | (Left (shr, prj), WTTProject shr' prj') |
|
+ | 823 | | shr == shr' && prj == prj' -> return $ Left wit |
|
+ | 824 | (Right (shr, rp), WTTRepo shr' rp' _ _ _) |
|
+ | 825 | | shr == shr' && rp == rp' -> return $ Left wit |
|
+ | 826 | _ -> throwE "Create target and ticket context are different \ |
|
+ | 827 | \local projects" |
|
+ | 828 | ||
+ | 829 | fetchTracker (h, luTarget, luContext, mpatch) = do |
|
+ | 830 | (iid, era) <- do |
|
+ | 831 | iid <- lift $ runDB $ either entityKey id <$> insertBy' (Instance h) |
|
+ | 832 | result <- lift $ fetchRemoteActor iid h luTarget |
|
+ | 833 | case result of |
|
+ | 834 | Left e -> throwE $ T.pack $ displayException e |
|
+ | 835 | Right (Left e) -> throwE $ T.pack $ show e |
|
+ | 836 | Right (Right mera) -> do |
|
+ | 837 | era <- fromMaybeE mera "target found to be a collection, not an actor" |
|
+ | 838 | return (iid, era) |
|
+ | 839 | return (iid, era, if luTarget == luContext then Nothing else Just luContext, mpatch) |
|
+ | 840 | ||
+ | 841 | prepareProject now (Left (WTTProject shr prj)) = Left <$> do |
|
… | … | … | … |
- | 829 | return (shr, ej, obiidAccept) |
|
- | 830 | prepareProject _ (Right (iid, era, mlu)) = lift $ Right <$> do |
|
- | 831 | mroid <- for mlu $ \ lu -> either entityKey id <$> insertBy' (RemoteObject iid lu) |
|
- | 832 | return (era, mroid) |
|
+ | 1018 | return (shr, Left ej, obiidAccept) |
|
+ | 1019 | prepareProject now (Left (WTTRepo shr rp mb vcs diff)) = Left <$> do |
|
+ | 1020 | mer <- lift $ runMaybeT $ do |
|
+ | 1021 | sid <- MaybeT $ getKeyBy $ UniqueSharer shr |
|
+ | 1022 | MaybeT $ getBy $ UniqueRepo rp sid |
|
+ | 1023 | er@(Entity _ r) <- fromMaybeE mer "Local context: no such repo" |
|
+ | 1024 | unless (repoVcs r == vcs) $ throwE "Repo VCS and patch VCS mismatch" |
|
+ | 1025 | obiidAccept <- lift $ insertEmptyOutboxItem (repoOutbox r) now |
|
+ | 1026 | return (shr, Right (er, mb, diff), obiidAccept) |
|
+ | 1027 | prepareProject _ (Right (iid, era, mlu, mpatch)) = lift $ Right <$> do |
|
+ | 1028 | let mlu' = |
|
+ | 1029 | case mpatch of |
|
+ | 1030 | Just (Just luBranch, _, _) -> Just luBranch |
|
+ | 1031 | Nothing -> mlu |
|
+ | 1032 | mroid <- for mlu' $ \ lu -> either entityKey id <$> insertBy' (RemoteObject iid lu) |
|
+ | 1033 | let removeBranch (mb, typ, diff) = (typ, diff) |
|
+ | 1034 | return (era, mroid, removeBranch <$> mpatch) |
|
… | … | … | … |
- | 871 | case project of |
|
- | 872 | Left (_shr, Entity jid _j, obiidAccept) -> do |
|
- | 873 | tclid <- insert TicketContextLocal |
|
- | 874 | { ticketContextLocalTicket = tid |
|
- | 875 | , ticketContextLocalAccept = obiidAccept |
|
- | 876 | } |
|
- | 877 | insert_ TicketProjectLocal |
|
- | 878 | { ticketProjectLocalContext = tclid |
|
- | 879 | , ticketProjectLocalProject = jid |
|
- | 880 | } |
|
- | 881 | Right (Entity raid _ra, mroid) -> |
|
- | 882 | insert_ TicketProjectRemote |
|
- | 883 | { ticketProjectRemoteTicket = talid |
|
- | 884 | , ticketProjectRemoteTracker = raid |
|
- | 885 | , ticketProjectRemoteProject = mroid |
|
- | 886 | } |
|
- | 887 | return talid |
|
- | 888 | ||
- | 889 | insertCreateToOutbox shrUser blinded (uContext, title, desc, source, uTarget) now obiidCreate talid = do |
|
+ | 1073 | mptid <- |
|
+ | 1074 | case project of |
|
+ | 1075 | Left (_shr, ent, obiidAccept) -> do |
|
+ | 1076 | tclid <- insert TicketContextLocal |
|
+ | 1077 | { ticketContextLocalTicket = tid |
|
+ | 1078 | , ticketContextLocalAccept = obiidAccept |
|
+ | 1079 | } |
|
+ | 1080 | case ent of |
|
+ | 1081 | Left (Entity jid _) -> do |
|
+ | 1082 | insert_ TicketProjectLocal |
|
+ | 1083 | { ticketProjectLocalContext = tclid |
|
+ | 1084 | , ticketProjectLocalProject = jid |
|
+ | 1085 | } |
|
+ | 1086 | return Nothing |
|
+ | 1087 | Right (Entity rid _, mb, diff) -> Just <$> do |
|
+ | 1088 | insert_ TicketRepoLocal |
|
+ | 1089 | { ticketRepoLocalContext = tclid |
|
+ | 1090 | , ticketRepoLocalRepo = rid |
|
+ | 1091 | , ticketRepoLocalBranch = mb |
|
+ | 1092 | } |
|
+ | 1093 | insert $ Patch tid now diff |
|
+ | 1094 | Right (Entity raid _, mroid, mpatch) -> do |
|
+ | 1095 | insert_ TicketProjectRemote |
|
+ | 1096 | { ticketProjectRemoteTicket = talid |
|
+ | 1097 | , ticketProjectRemoteTracker = raid |
|
+ | 1098 | , ticketProjectRemoteProject = mroid |
|
+ | 1099 | } |
|
+ | 1100 | for mpatch $ \ (_typ, diff) -> insert $ Patch tid now diff |
|
+ | 1101 | return (talid, mptid) |
|
+ | 1102 | ||
+ | 1103 | insertCreateToOutbox shrUser blinded context title desc source now obiidCreate talid mptid = do |
|
… | … | … | … |
+ | 1117 | encodeRouteHome <- getEncodeRouteHome |
|
+ | 1121 | mptkhid <- traverse encodeKeyHashid mptid |
|
- | 908 | let luAttrib = encodeRouteLocal $ SharerR shrUser |
|
+ | 1124 | let luTicket = encodeRouteLocal $ SharerTicketR shrUser talkhid |
|
+ | 1125 | luAttrib = encodeRouteLocal $ SharerR shrUser |
|
+ | 1126 | (uTarget, uContext, mmr) = |
|
+ | 1127 | case context of |
|
+ | 1128 | Left (WTTProject shr prj) -> |
|
+ | 1129 | let uProject = encodeRouteHome $ ProjectR shr prj |
|
+ | 1130 | in (uProject, uProject, Nothing) |
|
+ | 1131 | Left (WTTRepo shr rp mb vcs diff) -> |
|
+ | 1132 | let uRepo = encodeRouteHome $ RepoR shr rp |
|
+ | 1133 | mr = MergeRequest |
|
+ | 1134 | { mrOrigin = Nothing |
|
+ | 1135 | , mrTarget = |
|
+ | 1136 | encodeRouteLocal $ |
|
+ | 1137 | case mb of |
|
+ | 1138 | Nothing -> RepoR shr rp |
|
+ | 1139 | Just b -> RepoBranchR shr rp b |
|
+ | 1140 | , mrPatch = Right |
|
+ | 1141 | ( hLocal |
|
+ | 1142 | , AP.Patch |
|
+ | 1143 | { AP.patchLocal = Just |
|
+ | 1144 | ( hLocal |
|
+ | 1145 | , PatchLocal |
|
+ | 1146 | { patchId = |
|
+ | 1147 | case mptkhid of |
|
+ | 1148 | Nothing -> error "mptkhid is Nothing" |
|
+ | 1149 | Just ptkhid -> |
|
+ | 1150 | encodeRouteLocal $ |
|
+ | 1151 | SharerPatchVersionR shrUser talkhid ptkhid |
|
+ | 1152 | , patchContext = luTicket |
|
+ | 1153 | , patchPrevVersions = [] |
|
+ | 1154 | } |
|
+ | 1155 | ) |
|
+ | 1156 | , AP.patchAttributedTo = luAttrib |
|
+ | 1157 | , AP.patchPublished = Just now |
|
+ | 1158 | , AP.patchType = |
|
+ | 1159 | case vcs of |
|
+ | 1160 | VCSDarcs -> PatchTypeDarcs |
|
+ | 1161 | VCSGit -> error "createTicketC VCSGit" |
|
+ | 1162 | , AP.patchContent = diff |
|
+ | 1163 | } |
|
+ | 1164 | ) |
|
+ | 1165 | } |
|
+ | 1166 | in (uRepo, uRepo, Just (hLocal, mr)) |
|
+ | 1167 | Right (hContext, luTarget, luContext, mpatch) -> |
|
+ | 1168 | let mr (mluBranch, typ, diff) = MergeRequest |
|
+ | 1169 | { mrOrigin = Nothing |
|
+ | 1170 | , mrTarget = fromMaybe luContext mluBranch |
|
+ | 1171 | , mrPatch = Right |
|
+ | 1172 | ( hLocal |
|
+ | 1173 | , AP.Patch |
|
+ | 1174 | { AP.patchLocal = Just |
|
+ | 1175 | ( hLocal |
|
+ | 1176 | , PatchLocal |
|
+ | 1177 | { patchId = |
|
+ | 1178 | case mptkhid of |
|
+ | 1179 | Nothing -> error "mptkhid is Nothing" |
|
+ | 1180 | Just ptkhid -> |
|
+ | 1181 | encodeRouteLocal $ |
|
+ | 1182 | SharerPatchVersionR shrUser talkhid ptkhid |
|
+ | 1183 | , patchContext = luTicket |
|
+ | 1184 | , patchPrevVersions = [] |
|
+ | 1185 | } |
|
+ | 1186 | ) |
|
+ | 1187 | , AP.patchAttributedTo = luAttrib |
|
+ | 1188 | , AP.patchPublished = Just now |
|
+ | 1189 | , AP.patchType = typ |
|
+ | 1190 | , AP.patchContent = diff |
|
+ | 1191 | } |
|
+ | 1192 | ) |
|
+ | 1193 | } |
|
+ | 1194 | in ( ObjURI hContext luTarget |
|
+ | 1195 | , ObjURI hContext luContext |
|
+ | 1196 | , (hContext,) . mr <$> mpatch |
|
+ | 1197 | ) |
|
… | … | … | … |
- | 983 | { ticketId = encodeRouteLocal $ SharerTicketR shrUser talkhid |
|
+ | 1272 | { ticketId = luTicket |
|
- | 986 | , ticketTeam = Just $ encodeRouteLocal $ SharerTicketTeamR shrUser talkhid |
|
+ | 1275 | , ticketTeam = Nothing -- Just $ encodeRouteLocal $ SharerTicketTeamR shrUser talkhid |
|
… | … | … | … |
- | 1008 | , AP.ticketAttachment = Nothing |
|
+ | 1297 | , AP.ticketAttachment = mmr |
|
- | 1016 | insertAcceptToOutbox (shrJ, Entity _ j, obiidAccept) shrU obiidCreate talid actors colls = do |
|
+ | 1305 | insertAcceptToOutbox (shrJ, ent, obiidAccept) shrU obiidCreate talid actors colls = do |
|
- | 1023 | let prjJ = projectIdent j |
|
- | 1024 | summary <- |
|
- | 1025 | TextHtml . TL.toStrict . renderHtml <$> |
|
- | 1026 | withUrlRenderer |
|
- | 1027 | [hamlet| |
|
- | 1028 | <p> |
|
- | 1029 | Project # |
|
- | 1030 | <a href=@{ProjectR shrJ prjJ}> |
|
- | 1031 | #{prj2text prjJ} |
|
- | 1032 | \ accepted # |
|
- | 1033 | <a href=@{SharerTicketR shrU talkhid}> |
|
- | 1034 | ticket |
|
- | 1035 | \ by # |
|
- | 1036 | <a href=@{SharerR shrU}> |
|
- | 1037 | #{shr2text shrU} |
|
- | 1038 | |] |
|
- | 1039 | let recips = map encodeRouteHome $ map renderLocalActor actors ++ map renderLocalPersonCollection colls |
|
+ | 1312 | let (outboxItemRoute, actorRoute) = |
|
+ | 1313 | case ent of |
|
+ | 1314 | Left (Entity _ j) -> |
|
+ | 1315 | let prj = projectIdent j |
|
+ | 1316 | in (ProjectOutboxItemR shrJ prj, ProjectR shrJ prj) |
|
+ | 1317 | Right (Entity _ r, _, _) -> |
|
+ | 1318 | let rp = repoIdent r |
|
+ | 1319 | in (RepoOutboxItemR shrJ rp, RepoR shrJ rp) |
|
+ | 1320 | recips = map encodeRouteHome $ map renderLocalActor actors ++ map renderLocalPersonCollection colls |
|
- | 1033 | { activityId = Just $ encodeRouteLocal $ ProjectOutboxItemR shrJ prjJ obikhidAccept |
|
- | 1034 | , activityActor = encodeRouteLocal $ ProjectR shrJ prjJ |
|
- | 1035 | , activitySummary = Just summary |
|
+ | 1314 | { activityId = Just $ encodeRouteLocal $ outboxItemRoute obikhidAccept |
|
+ | 1315 | , activityActor = encodeRouteLocal actorRoute |
|
+ | 1316 | , activitySummary = Nothing |
|
… | … | … | … |