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-08-05 |
Title | S2S unresolve, C2S resolve & unresolve, use C2S in the UI buttons |
Description |
Edit file config/models 0 → 0
- | 371 | closed UTCTime |
|
- | 372 | closer PersonId Maybe |
|
… | … | … | … |
Edit file src/Vervis/API.hs 0 → 0
+ | 23 | , resolveC |
|
… | … | … | … |
- | 859 | , ticketClosed = UTCTime (ModifiedJulianDay 0) 0 |
|
- | 860 | , ticketCloser = Nothing |
|
… | … | … | … |
- | 1516 | , ticketClosed = UTCTime (ModifiedJulianDay 0) 0 |
|
- | 1517 | , ticketCloser = Nothing |
|
… | … | … | … |
+ | 1582 | verifyHosterRecip _ _ (Right _) = return () |
|
+ | 1583 | verifyHosterRecip localRecips name (Left wi) = |
|
+ | 1584 | fromMaybeE (verify wi) $ |
|
+ | 1585 | name <> " ticket hoster actor isn't listed as a recipient" |
|
+ | 1586 | where |
|
+ | 1587 | verify (WorkItemSharerTicket shr _ _) = do |
|
+ | 1588 | sharerSet <- lookup shr localRecips |
|
+ | 1589 | guard $ localRecipSharer $ localRecipSharerDirect sharerSet |
|
+ | 1590 | verify (WorkItemProjectTicket shr prj _) = do |
|
+ | 1591 | sharerSet <- lookup shr localRecips |
|
+ | 1592 | projectSet <- lookup prj $ localRecipProjectRelated sharerSet |
|
+ | 1593 | guard $ localRecipProject $ localRecipProjectDirect projectSet |
|
+ | 1594 | verify (WorkItemRepoPatch shr rp _) = do |
|
+ | 1595 | sharerSet <- lookup shr localRecips |
|
+ | 1596 | repoSet <- lookup rp $ localRecipRepoRelated sharerSet |
|
+ | 1597 | guard $ localRecipRepo $ localRecipRepoDirect repoSet |
|
+ | 1598 | ||
+ | 1599 | workItemRecipSieve wiFollowers (WorkItemDetail ident context author) = |
|
+ | 1600 | let authorC = |
|
+ | 1601 | case author of |
|
+ | 1602 | Left shr -> [LocalPersonCollectionSharerFollowers shr] |
|
+ | 1603 | Right _ -> [] |
|
+ | 1604 | ticketC = |
|
+ | 1605 | case ident of |
|
+ | 1606 | Left (wi, _) -> [wiFollowers wi] |
|
+ | 1607 | Right _ -> [] |
|
+ | 1608 | (contextA, contextC) = |
|
+ | 1609 | case context of |
|
+ | 1610 | Left local -> |
|
+ | 1611 | case local of |
|
+ | 1612 | Left (shr, prj) -> |
|
+ | 1613 | ( [LocalActorProject shr prj] |
|
+ | 1614 | , [ LocalPersonCollectionProjectTeam shr prj |
|
+ | 1615 | , LocalPersonCollectionProjectFollowers shr prj |
|
+ | 1616 | ] |
|
+ | 1617 | ) |
|
+ | 1618 | Right (shr, rp) -> |
|
+ | 1619 | ( [LocalActorRepo shr rp] |
|
+ | 1620 | , [ LocalPersonCollectionRepoTeam shr rp |
|
+ | 1621 | , LocalPersonCollectionRepoFollowers shr rp |
|
+ | 1622 | ] |
|
+ | 1623 | ) |
|
+ | 1624 | Right _ -> ([], []) |
|
+ | 1625 | in (contextA, authorC ++ ticketC ++ contextC) |
|
+ | 1626 | ||
+ | 1627 | workItemActor (WorkItemSharerTicket shr _ _) = LocalActorSharer shr |
|
+ | 1628 | workItemActor (WorkItemProjectTicket shr prj _) = LocalActorProject shr prj |
|
+ | 1629 | workItemActor (WorkItemRepoPatch shr rp _) = LocalActorRepo shr rp |
|
+ | 1630 | ||
+ | 1631 | actorOutboxItem (LocalActorSharer shr) = SharerOutboxItemR shr |
|
+ | 1632 | actorOutboxItem (LocalActorProject shr prj) = ProjectOutboxItemR shr prj |
|
+ | 1633 | actorOutboxItem (LocalActorRepo shr rp) = RepoOutboxItemR shr rp |
|
+ | 1634 | ||
… | … | … | … |
- | 1751 | runWorkerExcept action = do |
|
- | 1752 | site <- askSite |
|
- | 1753 | ExceptT $ liftIO $ runWorker (runExceptT action) site |
|
- | 1754 | verifyHosterRecip _ _ (Right _) = return () |
|
- | 1755 | verifyHosterRecip localRecips name (Left wi) = |
|
- | 1756 | fromMaybeE (verify wi) $ |
|
- | 1757 | name <> " ticket hoster actor isn't listed as a recipient" |
|
- | 1758 | where |
|
- | 1759 | verify (WorkItemSharerTicket shr _ _) = do |
|
- | 1760 | sharerSet <- lookup shr localRecips |
|
- | 1761 | guard $ localRecipSharer $ localRecipSharerDirect sharerSet |
|
- | 1762 | verify (WorkItemProjectTicket shr prj _) = do |
|
- | 1763 | sharerSet <- lookup shr localRecips |
|
- | 1764 | projectSet <- lookup prj $ localRecipProjectRelated sharerSet |
|
- | 1765 | guard $ localRecipProject $ localRecipProjectDirect projectSet |
|
- | 1766 | verify (WorkItemRepoPatch shr rp _) = do |
|
- | 1767 | sharerSet <- lookup shr localRecips |
|
- | 1768 | repoSet <- lookup rp $ localRecipRepoRelated sharerSet |
|
- | 1769 | guard $ localRecipRepo $ localRecipRepoDirect repoSet |
|
- | 1767 | workItemRecipSieve wiFollowers (WorkItemDetail ident context author) = |
|
- | 1768 | let authorC = |
|
- | 1769 | case author of |
|
- | 1770 | Left shr -> [LocalPersonCollectionSharerFollowers shr] |
|
- | 1771 | Right _ -> [] |
|
- | 1772 | ticketC = |
|
- | 1773 | case ident of |
|
- | 1774 | Left (wi, _) -> [wiFollowers wi] |
|
- | 1775 | Right _ -> [] |
|
- | 1776 | (contextA, contextC) = |
|
- | 1777 | case context of |
|
- | 1778 | Left local -> |
|
- | 1779 | case local of |
|
- | 1780 | Left (shr, prj) -> |
|
- | 1781 | ( [LocalActorProject shr prj] |
|
- | 1782 | , [ LocalPersonCollectionProjectTeam shr prj |
|
- | 1783 | , LocalPersonCollectionProjectFollowers shr prj |
|
- | 1784 | ] |
|
- | 1785 | ) |
|
- | 1786 | Right (shr, rp) -> |
|
- | 1787 | ( [LocalActorRepo shr rp] |
|
- | 1788 | , [ LocalPersonCollectionRepoTeam shr rp |
|
- | 1789 | , LocalPersonCollectionRepoFollowers shr rp |
|
- | 1790 | ] |
|
- | 1791 | ) |
|
- | 1792 | Right _ -> ([], []) |
|
- | 1793 | in (contextA, authorC ++ ticketC ++ contextC) |
|
… | … | … | … |
- | 1846 | where |
|
- | 1847 | authorAudience (Left shr) = AudLocal [LocalActorSharer shr] [] |
|
- | 1848 | authorAudience (Right (ObjURI h lu)) = AudRemote h [lu] [] |
|
- | 1849 | actorOutboxItem (LocalActorSharer shr) = SharerOutboxItemR shr |
|
- | 1850 | actorOutboxItem (LocalActorProject shr prj) = ProjectOutboxItemR shr prj |
|
- | 1851 | actorOutboxItem (LocalActorRepo shr rp) = RepoOutboxItemR shr rp |
|
+ | 1850 | ||
+ | 1851 | insertAcceptOnTicketStatus shrUser wi (WorkItemDetail _ ctx author) obiidResolve obiidAccept = do |
|
+ | 1852 | encodeRouteLocal <- getEncodeRouteLocal |
|
+ | 1853 | encodeRouteHome <- getEncodeRouteHome |
|
+ | 1854 | wiFollowers <- askWorkItemFollowers |
|
+ | 1855 | hLocal <- asksSite siteInstanceHost |
|
+ | 1856 | ||
+ | 1857 | obikhidResolve <- encodeKeyHashid obiidResolve |
|
+ | 1858 | obikhidAccept <- encodeKeyHashid obiidAccept |
|
+ | 1859 | ||
+ | 1860 | let audAuthor = |
|
+ | 1861 | AudLocal |
|
+ | 1862 | [LocalActorSharer shrUser] |
|
+ | 1863 | [LocalPersonCollectionSharerFollowers shrUser] |
|
+ | 1864 | audTicketContext = contextAudience ctx |
|
+ | 1865 | audTicketAuthor = authorAudience author |
|
+ | 1866 | audTicketFollowers = AudLocal [] [wiFollowers wi] |
|
+ | 1867 | ||
+ | 1868 | (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = |
|
+ | 1869 | collectAudience $ |
|
+ | 1870 | audAuthor : |
|
+ | 1871 | audTicketAuthor : |
|
+ | 1872 | audTicketFollowers : |
|
+ | 1873 | audTicketContext |
|
+ | 1874 | ||
+ | 1875 | actor = workItemActor wi |
|
+ | 1876 | recips = map encodeRouteHome audLocal ++ audRemote |
|
+ | 1877 | doc = Doc hLocal Activity |
|
+ | 1878 | { activityId = |
|
+ | 1879 | Just $ encodeRouteLocal $ |
|
+ | 1880 | actorOutboxItem actor obikhidAccept |
|
+ | 1881 | , activityActor = encodeRouteLocal $ renderLocalActor actor |
|
+ | 1882 | , activitySummary = Nothing |
|
+ | 1883 | , activityAudience = Audience recips [] [] [] [] [] |
|
+ | 1884 | , activitySpecific = AcceptActivity Accept |
|
+ | 1885 | { acceptObject = |
|
+ | 1886 | encodeRouteHome $ SharerOutboxItemR shrUser obikhidResolve |
|
+ | 1887 | , acceptResult = Nothing |
|
+ | 1888 | } |
|
+ | 1889 | } |
|
+ | 1890 | ||
+ | 1891 | update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc] |
|
+ | 1892 | return (doc, recipientSet, remoteActors, fwdHosts) |
|
+ | 1893 | ||
+ | 1894 | resolveC |
|
+ | 1895 | :: Entity Person |
|
+ | 1896 | -> Sharer |
|
+ | 1897 | -> Maybe TextHtml |
|
+ | 1898 | -> Audience URIMode |
|
+ | 1899 | -> Resolve URIMode |
|
+ | 1900 | -> ExceptT Text Handler OutboxItemId |
|
+ | 1901 | resolveC (Entity pidUser personUser) sharerUser summary audience (Resolve uObject) = do |
|
+ | 1902 | let shrUser = sharerIdent sharerUser |
|
+ | 1903 | object <- parseWorkItem "Resolve object" uObject |
|
+ | 1904 | ParsedAudience localRecips remoteRecips blinded fwdHosts <- do |
|
+ | 1905 | mrecips <- parseAudience audience |
|
+ | 1906 | fromMaybeE mrecips "Offer Ticket with no recipients" |
|
+ | 1907 | federation <- asksSite $ appFederation . appSettings |
|
+ | 1908 | unless (federation || null remoteRecips) $ |
|
+ | 1909 | throwE "Federation disabled, but remote recipients specified" |
|
+ | 1910 | verifyHosterRecip localRecips "Parent" object |
|
+ | 1911 | now <- liftIO getCurrentTime |
|
+ | 1912 | ticketDetail <- runWorkerExcept $ getWorkItemDetail "Object" object |
|
+ | 1913 | (obiid, doc, remotesHttp, maybeAccept) <- runDBExcept $ do |
|
+ | 1914 | (obiidResolve, docResolve, luResolve) <- lift $ insertResolveToOutbox shrUser now (personOutbox personUser) blinded |
|
+ | 1915 | remotesHttpResolve <- do |
|
+ | 1916 | wiFollowers <- askWorkItemFollowers |
|
+ | 1917 | let sieve = |
|
+ | 1918 | let (actors, colls) = |
|
+ | 1919 | workItemRecipSieve wiFollowers ticketDetail |
|
+ | 1920 | in makeRecipientSet |
|
+ | 1921 | actors |
|
+ | 1922 | (LocalPersonCollectionSharerFollowers shrUser : |
|
+ | 1923 | colls |
|
+ | 1924 | ) |
|
+ | 1925 | moreRemoteRecips <- |
|
+ | 1926 | lift $ |
|
+ | 1927 | deliverLocal' |
|
+ | 1928 | True |
|
+ | 1929 | (LocalActorSharer shrUser) |
|
+ | 1930 | (personInbox personUser) |
|
+ | 1931 | obiidResolve |
|
+ | 1932 | (localRecipSieve sieve False localRecips) |
|
+ | 1933 | unless (federation || null moreRemoteRecips) $ |
|
+ | 1934 | throwE "Federation disabled, but recipient collection remote members found" |
|
+ | 1935 | lift $ deliverRemoteDB'' fwdHosts obiidResolve remoteRecips moreRemoteRecips |
|
+ | 1936 | maccept <- |
|
+ | 1937 | case widIdent ticketDetail of |
|
+ | 1938 | Right _ -> return Nothing |
|
+ | 1939 | Left (wi, ltid) -> Just <$> do |
|
+ | 1940 | mhoster <- |
|
+ | 1941 | lift $ runMaybeT $ |
|
+ | 1942 | case wi of |
|
+ | 1943 | WorkItemSharerTicket shr _ _ -> do |
|
+ | 1944 | sid <- MaybeT $ getKeyBy $ UniqueSharer shr |
|
+ | 1945 | p <- MaybeT (getValBy $ UniquePersonIdent sid) |
|
+ | 1946 | return (personOutbox p, personInbox p) |
|
+ | 1947 | WorkItemProjectTicket shr prj _ -> do |
|
+ | 1948 | sid <- MaybeT $ getKeyBy $ UniqueSharer shr |
|
+ | 1949 | j <- MaybeT (getValBy $ UniqueProject prj sid) |
|
+ | 1950 | return (projectOutbox j, projectInbox j) |
|
+ | 1951 | WorkItemRepoPatch shr rp _ -> do |
|
+ | 1952 | sid <- MaybeT $ getKeyBy $ UniqueSharer shr |
|
+ | 1953 | r <- MaybeT (getValBy $ UniqueRepo rp sid) |
|
+ | 1954 | return (repoOutbox r, repoInbox r) |
|
+ | 1955 | (obidHoster, ibidHoster) <- fromMaybeE mhoster "Ticket hoster not in DB" |
|
+ | 1956 | obiidAccept <- lift $ insertEmptyOutboxItem obidHoster now |
|
+ | 1957 | lift $ insertResolve ltid obiidResolve obiidAccept |
|
+ | 1958 | (docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <- |
|
+ | 1959 | lift $ insertAcceptOnTicketStatus shrUser wi ticketDetail obiidResolve obiidAccept |
|
+ | 1960 | knownRemoteRecipsAccept <- |
|
+ | 1961 | lift $ |
|
+ | 1962 | deliverLocal' |
|
+ | 1963 | False |
|
+ | 1964 | (workItemActor wi) |
|
+ | 1965 | ibidHoster |
|
+ | 1966 | obiidAccept |
|
+ | 1967 | localRecipsAccept |
|
+ | 1968 | lift $ (obiidAccept,docAccept,fwdHostsAccept,) <$> |
|
+ | 1969 | deliverRemoteDB'' fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept |
|
+ | 1970 | return (obiidResolve, docResolve, remotesHttpResolve, maccept) |
|
+ | 1971 | lift $ do |
|
+ | 1972 | forkWorker "resolveC: async HTTP Resolve delivery" $ deliverRemoteHttp' fwdHosts obiid doc remotesHttp |
|
+ | 1973 | for_ maybeAccept $ \ (obiidAccept, docAccept, fwdHostsAccept, remotesHttpAccept) -> |
|
+ | 1974 | forkWorker "resolveC: async HTTP Accept delivery" $ deliverRemoteHttp' fwdHostsAccept obiidAccept docAccept remotesHttpAccept |
|
+ | 1975 | return obiid |
|
+ | 1976 | where |
|
+ | 1977 | insertResolveToOutbox shrUser now obid blinded = do |
|
+ | 1978 | hLocal <- asksSite siteInstanceHost |
|
+ | 1979 | obiid <- insertEmptyOutboxItem obid now |
|
+ | 1980 | encodeRouteLocal <- getEncodeRouteLocal |
|
+ | 1981 | obikhid <- encodeKeyHashid obiid |
|
+ | 1982 | let luAct = encodeRouteLocal $ SharerOutboxItemR shrUser obikhid |
|
+ | 1983 | doc = Doc hLocal Activity |
|
+ | 1984 | { activityId = Just luAct |
|
+ | 1985 | , activityActor = encodeRouteLocal $ SharerR shrUser |
|
+ | 1986 | , activitySummary = summary |
|
+ | 1987 | , activityAudience = blinded |
|
+ | 1988 | , activitySpecific = ResolveActivity $ Resolve uObject |
|
+ | 1989 | } |
|
+ | 1990 | update obiid [OutboxItemActivity =. persistJSONObjectFromDoc doc] |
|
+ | 1991 | return (obiid, doc, luAct) |
|
+ | 1992 | ||
+ | 1993 | insertResolve ltid obiidResolve obiidAccept = do |
|
+ | 1994 | trid <- insert TicketResolve |
|
+ | 1995 | { ticketResolveTicket = ltid |
|
+ | 1996 | , ticketResolveAccept = obiidAccept |
|
+ | 1997 | } |
|
+ | 1998 | insert_ TicketResolveLocal |
|
+ | 1999 | { ticketResolveLocalTicket = trid |
|
+ | 2000 | , ticketResolveLocalActivity = obiidResolve |
|
+ | 2001 | } |
|
+ | 2002 | tid <- localTicketTicket <$> getJust ltid |
|
+ | 2003 | update tid [TicketStatus =. TSClosed] |
|
… | … | … | … |
- | 2002 | :: ShrIdent |
|
+ | 2154 | :: Entity Person |
|
+ | 2155 | -> Sharer |
|
- | 2008 | undoC shrUser summary audience undo@(Undo luObject) = do |
|
+ | 2161 | undoC (Entity _pidUser personUser) sharerUser summary audience undo@(Undo uObject) = do |
|
+ | 2162 | let shrUser = sharerIdent sharerUser |
|
+ | 2163 | object <- parseActivity uObject |
|
- | 2013 | fromMaybeE mrecips "Follow with no recipients" |
|
+ | 2168 | fromMaybeE mrecips "Undo with no recipients" |
|
- | 2017 | route <- |
|
- | 2018 | fromMaybeE |
|
- | 2019 | (decodeRouteLocal luObject) |
|
- | 2020 | "Undo object isn't a valid route" |
|
- | 2021 | obiidOriginal <- case route of |
|
- | 2022 | SharerOutboxItemR shr obikhid |
|
- | 2023 | | shr == shrUser -> |
|
- | 2024 | decodeKeyHashidE obikhid "Undo object invalid obikhid" |
|
- | 2025 | _ -> throwE "Undo object isn't actor's outbox item route" |
|
- | 2026 | (obiidUndo, doc, remotesHttp) <- runDBExcept $ do |
|
- | 2027 | Entity _pidAuthor personAuthor <- lift $ getAuthor shrUser |
|
- | 2028 | obi <- do |
|
- | 2029 | mobi <- lift $ get obiidOriginal |
|
- | 2030 | fromMaybeE mobi "Undo object obiid doesn't exist in DB" |
|
- | 2031 | unless (outboxItemOutbox obi == personOutbox personAuthor) $ |
|
- | 2032 | throwE "Undo object obiid belongs to different actor" |
|
- | 2033 | lift $ do |
|
- | 2034 | deleteFollow obiidOriginal |
|
- | 2035 | deleteFollowRemote obiidOriginal |
|
- | 2036 | deleteFollowRemoteRequest obiidOriginal |
|
- | 2037 | let obidAuthor = personOutbox personAuthor |
|
- | 2038 | (obiidUndo, doc, luUndo) <- insertUndoToOutbox obidAuthor blinded |
|
- | 2039 | let ibidAuthor = personInbox personAuthor |
|
- | 2040 | fsidAuthor = personFollowers personAuthor |
|
- | 2041 | knownRemotes <- deliverLocal shrUser ibidAuthor fsidAuthor obiidUndo localRecips |
|
- | 2042 | remotesHttp <- deliverRemoteDB'' fwdHosts obiidUndo remoteRecips knownRemotes |
|
- | 2043 | return (obiidUndo, doc, remotesHttp) |
|
- | 2044 | lift $ forkWorker "undoC: Outbox POST handler: async HTTP delivery" $ deliverRemoteHttp' fwdHosts obiidUndo doc remotesHttp |
|
- | 2045 | return obiidUndo |
|
+ | 2172 | now <- liftIO getCurrentTime |
|
+ | 2173 | (obiid, doc, _lu, mwi) <- runDBExcept $ do |
|
+ | 2174 | (obiidUndo, docUndo, luUndo) <- lift $ insertUndoToOutbox shrUser now (personOutbox personUser) blinded |
|
+ | 2175 | mltid <- fmap join $ runMaybeT $ do |
|
+ | 2176 | object' <- MaybeT $ getActivity object |
|
+ | 2177 | deleteFollow shrUser object' <|> deleteResolve object' |
|
+ | 2178 | mwi <- lift $ traverse getWorkItem mltid |
|
+ | 2179 | return (obiidUndo, docUndo, luUndo, mwi) |
|
+ | 2180 | mticketDetail <- |
|
+ | 2181 | for mwi $ \ wi -> |
|
+ | 2182 | (wi,) <$> runWorkerExcept (getWorkItemDetail "Object" $ Left wi) |
|
+ | 2183 | wiFollowers <- askWorkItemFollowers |
|
+ | 2184 | let sieve = |
|
+ | 2185 | case mticketDetail of |
|
+ | 2186 | Nothing -> makeRecipientSet [] [LocalPersonCollectionSharerFollowers shrUser] |
|
+ | 2187 | Just (_wi, ticketDetail) -> |
|
+ | 2188 | let (actors, colls) = |
|
+ | 2189 | workItemRecipSieve wiFollowers ticketDetail |
|
+ | 2190 | in makeRecipientSet |
|
+ | 2191 | actors |
|
+ | 2192 | (LocalPersonCollectionSharerFollowers shrUser : |
|
+ | 2193 | colls |
|
+ | 2194 | ) |
|
+ | 2195 | (remotes, maybeAccept) <- runDBExcept $ do |
|
+ | 2196 | remotesHttpUndo <- do |
|
+ | 2197 | moreRemoteRecips <- |
|
+ | 2198 | lift $ |
|
+ | 2199 | deliverLocal' |
|
+ | 2200 | True |
|
+ | 2201 | (LocalActorSharer shrUser) |
|
+ | 2202 | (personInbox personUser) |
|
+ | 2203 | obiid |
|
+ | 2204 | (localRecipSieve sieve True localRecips) |
|
+ | 2205 | unless (federation || null moreRemoteRecips) $ |
|
+ | 2206 | throwE "Federation disabled, but recipient collection remote members found" |
|
+ | 2207 | lift $ deliverRemoteDB'' fwdHosts obiid remoteRecips moreRemoteRecips |
|
+ | 2208 | maccept <- for mticketDetail $ \ (wi, ticketDetail) -> do |
|
+ | 2209 | mhoster <- |
|
+ | 2210 | lift $ runMaybeT $ |
|
+ | 2211 | case wi of |
|
+ | 2212 | WorkItemSharerTicket shr _ _ -> do |
|
+ | 2213 | sid <- MaybeT $ getKeyBy $ UniqueSharer shr |
|
+ | 2214 | p <- MaybeT (getValBy $ UniquePersonIdent sid) |
|
+ | 2215 | return (personOutbox p, personInbox p) |
|
+ | 2216 | WorkItemProjectTicket shr prj _ -> do |
|
+ | 2217 | sid <- MaybeT $ getKeyBy $ UniqueSharer shr |
|
+ | 2218 | j <- MaybeT (getValBy $ UniqueProject prj sid) |
|
+ | 2219 | return (projectOutbox j, projectInbox j) |
|
+ | 2220 | WorkItemRepoPatch shr rp _ -> do |
|
+ | 2221 | sid <- MaybeT $ getKeyBy $ UniqueSharer shr |
|
+ | 2222 | r <- MaybeT (getValBy $ UniqueRepo rp sid) |
|
+ | 2223 | return (repoOutbox r, repoInbox r) |
|
+ | 2224 | (obidHoster, ibidHoster) <- fromMaybeE mhoster "Ticket hoster not in DB" |
|
+ | 2225 | obiidAccept <- lift $ insertEmptyOutboxItem obidHoster now |
|
+ | 2226 | (docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <- |
|
+ | 2227 | lift $ insertAcceptOnTicketStatus shrUser wi ticketDetail obiid obiidAccept |
|
+ | 2228 | knownRemoteRecipsAccept <- |
|
+ | 2229 | lift $ |
|
+ | 2230 | deliverLocal' |
|
+ | 2231 | False |
|
+ | 2232 | (workItemActor wi) |
|
+ | 2233 | ibidHoster |
|
+ | 2234 | obiidAccept |
|
+ | 2235 | localRecipsAccept |
|
+ | 2236 | lift $ (obiidAccept,docAccept,fwdHostsAccept,) <$> |
|
+ | 2237 | deliverRemoteDB'' fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept |
|
+ | 2238 | return (remotesHttpUndo, maccept) |
|
+ | 2239 | lift $ do |
|
+ | 2240 | forkWorker "undoC: async HTTP Undo delivery" $ |
|
+ | 2241 | deliverRemoteHttp' fwdHosts obiid doc remotes |
|
+ | 2242 | for_ maybeAccept $ \ (obiidAccept, docAccept, fwdHostsAccept, remotesHttpAccept) -> |
|
+ | 2243 | forkWorker "undoC: async HTTP Accept delivery" $ |
|
+ | 2244 | deliverRemoteHttp' fwdHostsAccept obiidAccept docAccept remotesHttpAccept |
|
+ | 2245 | return obiid |
|
… | … | … | … |
- | 2092 | getAuthor shr = do |
|
- | 2093 | sid <- getKeyBy404 $ UniqueSharer shr |
|
- | 2094 | getBy404 $ UniquePersonIdent sid |
|
- | 2095 | deleteFollow obiid = do |
|
- | 2096 | mfid <- getKeyBy $ UniqueFollowFollow obiid |
|
- | 2097 | traverse_ delete mfid |
|
- | 2098 | deleteFollowRemote obiid = do |
|
- | 2099 | mfrid <- getKeyBy $ UniqueFollowRemoteFollow obiid |
|
- | 2100 | traverse_ delete mfrid |
|
- | 2101 | deleteFollowRemoteRequest obiid = do |
|
- | 2102 | mfrrid <- getKeyBy $ UniqueFollowRemoteRequestActivity obiid |
|
- | 2103 | traverse_ delete mfrrid |
|
- | 2104 | insertUndoToOutbox obid blinded = do |
|
+ | 2292 | insertUndoToOutbox shrUser now obid blinded = do |
|
+ | 2282 | obiid <- insertEmptyOutboxItem obid now |
|
- | 2096 | let activity mluAct = Doc hLocal Activity |
|
- | 2097 | { activityId = mluAct |
|
+ | 2285 | obikhid <- encodeKeyHashid obiid |
|
+ | 2286 | let luAct = encodeRouteLocal $ SharerOutboxItemR shrUser obikhid |
|
+ | 2287 | doc = Doc hLocal Activity |
|
+ | 2288 | { activityId = Just luAct |
|
- | 2103 | , activitySpecific = UndoActivity undo |
|
+ | 2294 | , activitySpecific = UndoActivity $ Undo uObject |
|
- | 2105 | now <- liftIO getCurrentTime |
|
- | 2106 | obiid <- insert OutboxItem |
|
- | 2107 | { outboxItemOutbox = obid |
|
- | 2108 | , outboxItemActivity = |
|
- | 2109 | persistJSONObjectFromDoc $ activity Nothing |
|
- | 2110 | , outboxItemPublished = now |
|
- | 2111 | } |
|
- | 2112 | obikhid <- encodeKeyHashid obiid |
|
- | 2113 | let luAct = encodeRouteLocal $ SharerOutboxItemR shrUser obikhid |
|
- | 2114 | doc = activity $ Just luAct |
|
+ | 2289 | deleteFollow shr (Left (actor, obiid)) = do |
|
+ | 2290 | deleteFollowLocal <|> deleteFollowRemote <|> deleteFollowRequest |
|
+ | 2291 | return Nothing |
|
+ | 2292 | where |
|
+ | 2293 | deleteFollowLocal = do |
|
+ | 2294 | fid <- MaybeT $ lift $ getKeyBy $ UniqueFollowFollow obiid |
|
+ | 2295 | unless (actor == LocalActorSharer shr) $ |
|
+ | 2296 | lift $ throwE "Undoing someone else's follow" |
|
+ | 2297 | lift $ lift $ delete fid |
|
+ | 2298 | deleteFollowRemote = do |
|
+ | 2299 | frid <- MaybeT $ lift $ getKeyBy $ UniqueFollowRemoteFollow obiid |
|
+ | 2300 | unless (actor == LocalActorSharer shr) $ |
|
+ | 2301 | lift $ throwE "Undoing someone else's follow" |
|
+ | 2302 | lift $ lift $ delete frid |
|
+ | 2303 | deleteFollowRequest = do |
|
+ | 2304 | frrid <- MaybeT $ lift $ getKeyBy $ UniqueFollowRemoteRequestActivity obiid |
|
+ | 2305 | unless (actor == LocalActorSharer shr) $ |
|
+ | 2306 | lift $ throwE "Undoing someone else's follow" |
|
+ | 2307 | lift $ lift $ delete frrid |
|
+ | 2308 | deleteFollow _ (Right _) = mzero |
|
+ | 2309 | ||
+ | 2310 | deleteResolve (Left (_, obiid)) = do |
|
+ | 2311 | Entity trlid trl <- MaybeT $ lift $ getBy $ UniqueTicketResolveLocalActivity obiid |
|
+ | 2312 | lift $ lift $ do |
|
+ | 2313 | let trid = ticketResolveLocalTicket trl |
|
+ | 2314 | tr <- getJust trid |
|
+ | 2315 | delete trlid |
|
+ | 2316 | delete trid |
|
+ | 2317 | return $ Just $ ticketResolveTicket tr |
|
+ | 2318 | deleteResolve (Right ractid) = do |
|
+ | 2319 | Entity trrid trr <- MaybeT $ lift $ getBy $ UniqueTicketResolveRemoteActivity ractid |
|
+ | 2320 | lift $ lift $ do |
|
+ | 2321 | let trid = ticketResolveRemoteTicket trr |
|
+ | 2322 | tr <- getJust trid |
|
+ | 2323 | delete trrid |
|
+ | 2324 | delete trid |
|
+ | 2325 | return $ Just $ ticketResolveTicket tr |
|
+ | 2326 | ||
… | … | … | … |
Edit file src/Vervis/ActivityPub.hs 0 → 0
+ | 55 | , parseActivity |
|
+ | 56 | , getActivity |
|
… | … | … | … |
+ | 1215 | ||
+ | 1216 | parseActivity u@(ObjURI h lu) = do |
|
+ | 1217 | hl <- hostIsLocal h |
|
+ | 1218 | if hl |
|
+ | 1219 | then Left <$> do |
|
+ | 1220 | route <- fromMaybeE (decodeRouteLocal lu) "Object isn't a valid route" |
|
+ | 1221 | case route of |
|
+ | 1222 | SharerOutboxItemR shr obikhid -> |
|
+ | 1223 | (LocalActorSharer shr,) <$> |
|
+ | 1224 | decodeKeyHashidE obikhid "No such obikhid" |
|
+ | 1225 | ProjectOutboxItemR shr prj obikhid -> do |
|
+ | 1226 | (LocalActorProject shr prj,) <$> |
|
+ | 1227 | decodeKeyHashidE obikhid "No such obikhid" |
|
+ | 1228 | RepoOutboxItemR shr rp obikhid -> do |
|
+ | 1229 | (LocalActorRepo shr rp,) <$> |
|
+ | 1230 | decodeKeyHashidE obikhid "No such obikhid" |
|
+ | 1231 | else return $ Right u |
|
+ | 1232 | ||
+ | 1233 | getActivity (Left (actor, obiid)) = Just . Left <$> do |
|
+ | 1234 | obid <- getActorOutbox actor |
|
+ | 1235 | obi <- do |
|
+ | 1236 | mobi <- lift $ get obiid |
|
+ | 1237 | fromMaybeE mobi "No such obiid" |
|
+ | 1238 | unless (outboxItemOutbox obi == obid) $ |
|
+ | 1239 | throwE "Actor/obiid mismatch" |
|
+ | 1240 | return (actor, obiid) |
|
+ | 1241 | where |
|
+ | 1242 | getActorOutbox (LocalActorSharer shr) = do |
|
+ | 1243 | sid <- do |
|
+ | 1244 | msid <- lift $ getKeyBy $ UniqueSharer shr |
|
+ | 1245 | fromMaybeE msid "No such sharer" |
|
+ | 1246 | p <- do |
|
+ | 1247 | mp <- lift $ getValBy $ UniquePersonIdent sid |
|
+ | 1248 | fromMaybeE mp "No such person" |
|
+ | 1249 | return $ personOutbox p |
|
+ | 1250 | getActorOutbox (LocalActorProject shr prj) = do |
|
+ | 1251 | sid <- do |
|
+ | 1252 | msid <- lift $ getKeyBy $ UniqueSharer shr |
|
+ | 1253 | fromMaybeE msid "No such sharer" |
|
+ | 1254 | j <- do |
|
+ | 1255 | mj <- lift $ getValBy $ UniqueProject prj sid |
|
+ | 1256 | fromMaybeE mj "No such project" |
|
+ | 1257 | return $ projectOutbox j |
|
+ | 1258 | getActorOutbox (LocalActorRepo shr rp) = do |
|
+ | 1259 | sid <- do |
|
+ | 1260 | msid <- lift $ getKeyBy $ UniqueSharer shr |
|
+ | 1261 | fromMaybeE msid "No such sharer" |
|
+ | 1262 | r <- do |
|
+ | 1263 | mr <- lift $ getValBy $ UniqueRepo rp sid |
|
+ | 1264 | fromMaybeE mr "No such repo" |
|
+ | 1265 | return $ repoOutbox r |
|
+ | 1266 | getActivity (Right u@(ObjURI h lu)) = lift $ runMaybeT $ Right <$> do |
|
+ | 1267 | iid <- MaybeT $ getKeyBy $ UniqueInstance h |
|
+ | 1268 | roid <- MaybeT $ getKeyBy $ UniqueRemoteObject iid lu |
|
+ | 1269 | MaybeT $ getKeyBy $ UniqueRemoteActivity roid |
|
… | … | … | … |
Edit file src/Vervis/Client.hs 0 → 0
+ | 26 | , resolve |
|
+ | 32 | , unresolve |
|
… | … | … | … |
- | 52 | import Web.ActivityPub hiding (Follow, Ticket) |
|
+ | 54 | import Web.ActivityPub hiding (Follow, Ticket, Project, Repo) |
|
+ | 64 | import Data.Either.Local |
|
+ | 69 | import Vervis.ActivityPub.Recipient |
|
+ | 75 | import Vervis.Ticket |
|
+ | 76 | import Vervis.WorkItem |
|
… | … | … | … |
+ | 330 | resolve |
|
+ | 331 | :: (MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App) |
|
+ | 332 | => ShrIdent |
|
+ | 333 | -> FedURI |
|
+ | 334 | -> m (Either Text (Maybe TextHtml, Audience URIMode, Resolve URIMode)) |
|
+ | 335 | resolve shrUser uObject = runExceptT $ do |
|
+ | 336 | encodeRouteHome <- getEncodeRouteHome |
|
+ | 337 | wiFollowers <- askWorkItemFollowers |
|
+ | 338 | object <- parseWorkItem "Resolve object" uObject |
|
+ | 339 | WorkItemDetail ident context author <- runWorkerExcept $ getWorkItemDetail "Object" object |
|
+ | 340 | let audAuthor = |
|
+ | 341 | AudLocal |
|
+ | 342 | [LocalActorSharer shrUser] |
|
+ | 343 | [LocalPersonCollectionSharerFollowers shrUser] |
|
+ | 344 | audTicketContext = contextAudience context |
|
+ | 345 | audTicketAuthor = authorAudience author |
|
+ | 346 | audTicketFollowers = |
|
+ | 347 | case ident of |
|
+ | 348 | Left (wi, _ltid) -> AudLocal [] [wiFollowers wi] |
|
+ | 349 | Right (ObjURI h _, luFollowers) -> AudRemote h [] [luFollowers] |
|
+ | 350 | ||
+ | 351 | (_, _, _, audLocal, audRemote) = |
|
+ | 352 | collectAudience $ |
|
+ | 353 | audAuthor : |
|
+ | 354 | audTicketAuthor : |
|
+ | 355 | audTicketFollowers : |
|
+ | 356 | audTicketContext |
|
+ | 357 | ||
+ | 358 | recips = map encodeRouteHome audLocal ++ audRemote |
|
+ | 359 | return (Nothing, Audience recips [] [] [] [] [], Resolve uObject) |
|
+ | 360 | ||
… | … | … | … |
- | 387 | encodeRouteLocal $ SharerOutboxItemR shrAuthor obikhidFollow |
|
+ | 424 | encodeRouteHome $ SharerOutboxItemR shrAuthor obikhidFollow |
|
… | … | … | … |
+ | 519 | ||
+ | 520 | data ActorEntity |
|
+ | 521 | = ActorPerson (Entity Person) |
|
+ | 522 | | ActorProject (Entity Project) |
|
+ | 523 | | ActorRepo (Entity Repo) |
|
+ | 524 | ||
+ | 525 | unresolve |
|
+ | 526 | :: (MonadUnliftIO m, MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App) |
|
+ | 527 | => ShrIdent |
|
+ | 528 | -> WorkItem |
|
+ | 529 | -> m (Either Text (Maybe TextHtml, Audience URIMode, Undo URIMode)) |
|
+ | 530 | unresolve shrUser wi = runExceptT $ do |
|
+ | 531 | encodeRouteHome <- getEncodeRouteHome |
|
+ | 532 | wiFollowers <- askWorkItemFollowers |
|
+ | 533 | WorkItemDetail ident context author <- runWorkerExcept $ getWorkItemDetail "Object" $ Left wi |
|
+ | 534 | ltid <- |
|
+ | 535 | case ident of |
|
+ | 536 | Left (_, ltid) -> return ltid |
|
+ | 537 | Right _ -> error "Local WorkItem expected!" |
|
+ | 538 | uResolve <- runSiteDBExcept $ do |
|
+ | 539 | mtrid <- lift $ getKeyBy $ UniqueTicketResolve ltid |
|
+ | 540 | trid <- fromMaybeE mtrid "Ticket already isn't resolved" |
|
+ | 541 | trx <- |
|
+ | 542 | lift $ |
|
+ | 543 | requireEitherAlt |
|
+ | 544 | (getValBy $ UniqueTicketResolveLocal trid) |
|
+ | 545 | (getValBy $ UniqueTicketResolveRemote trid) |
|
+ | 546 | "No TRX" |
|
+ | 547 | "Both TRL and TRR" |
|
+ | 548 | case trx of |
|
+ | 549 | Left trl -> lift $ do |
|
+ | 550 | let obiid = ticketResolveLocalActivity trl |
|
+ | 551 | obid <- outboxItemOutbox <$> getJust obiid |
|
+ | 552 | ent <- getOutboxActorEntity obid |
|
+ | 553 | obikhid <- encodeKeyHashid obiid |
|
+ | 554 | encodeRouteHome . flip outboxItemRoute obikhid <$> |
|
+ | 555 | actorEntityPath ent |
|
+ | 556 | Right trr -> lift $ do |
|
+ | 557 | roid <- |
|
+ | 558 | remoteActivityIdent <$> |
|
+ | 559 | getJust (ticketResolveRemoteActivity trr) |
|
+ | 560 | ro <- getJust roid |
|
+ | 561 | i <- getJust $ remoteObjectInstance ro |
|
+ | 562 | return $ ObjURI (instanceHost i) (remoteObjectIdent ro) |
|
+ | 563 | let audAuthor = |
|
+ | 564 | AudLocal |
|
+ | 565 | [LocalActorSharer shrUser] |
|
+ | 566 | [LocalPersonCollectionSharerFollowers shrUser] |
|
+ | 567 | audTicketContext = contextAudience context |
|
+ | 568 | audTicketAuthor = authorAudience author |
|
+ | 569 | audTicketFollowers = AudLocal [] [wiFollowers wi] |
|
+ | 570 | ||
+ | 571 | (_, _, _, audLocal, audRemote) = |
|
+ | 572 | collectAudience $ |
|
+ | 573 | audAuthor : |
|
+ | 574 | audTicketAuthor : |
|
+ | 575 | audTicketFollowers : |
|
+ | 576 | audTicketContext |
|
+ | 577 | ||
+ | 578 | recips = map encodeRouteHome audLocal ++ audRemote |
|
+ | 579 | return (Nothing, Audience recips [] [] [] [] [], Undo uResolve) |
|
+ | 580 | where |
|
+ | 581 | getOutboxActorEntity obid = do |
|
+ | 582 | mp <- getBy $ UniquePersonOutbox obid |
|
+ | 583 | mj <- getBy $ UniqueProjectOutbox obid |
|
+ | 584 | mr <- getBy $ UniqueRepoOutbox obid |
|
+ | 585 | case (mp, mj, mr) of |
|
+ | 586 | (Nothing, Nothing, Nothing) -> error "obid not in use" |
|
+ | 587 | (Just p, Nothing, Nothing) -> return $ ActorPerson p |
|
+ | 588 | (Nothing, Just j, Nothing) -> return $ ActorProject j |
|
+ | 589 | (Nothing, Nothing, Just r) -> return $ ActorRepo r |
|
+ | 590 | actorEntityPath (ActorPerson (Entity _ p)) = |
|
+ | 591 | LocalActorSharer . sharerIdent <$> getJust (personIdent p) |
|
+ | 592 | actorEntityPath (ActorProject (Entity _ j)) = |
|
+ | 593 | flip LocalActorProject (projectIdent j) . sharerIdent <$> |
|
+ | 594 | getJust (projectSharer j) |
|
+ | 595 | actorEntityPath (ActorRepo (Entity _ r)) = |
|
+ | 596 | flip LocalActorRepo (repoIdent r) . sharerIdent <$> |
|
+ | 597 | getJust (repoSharer r) |
|
+ | 598 | outboxItemRoute (LocalActorSharer shr) = SharerOutboxItemR shr |
|
+ | 599 | outboxItemRoute (LocalActorProject shr prj) = ProjectOutboxItemR shr prj |
|
+ | 600 | outboxItemRoute (LocalActorRepo shr rp) = RepoOutboxItemR shr rp |
|
… | … | … | … |
Edit file src/Vervis/Federation/Offer.hs 0 → 0
+ | 42 | import Data.Either |
|
… | … | … | … |
- | 537 | undoF |
|
- | 538 | :: Route App |
|
- | 539 | -> AppDB (Entity a) |
|
- | 540 | -> (a -> InboxId) |
|
- | 541 | -> (a -> FollowerSetId) |
|
- | 542 | -> (Key a -> FollowerSetId -> AppDB (Maybe Text)) |
|
- | 543 | -> UTCTime |
|
- | 544 | -> RemoteAuthor |
|
- | 545 | -> ActivityBody |
|
- | 546 | -> Maybe (LocalRecipientSet, ByteString) |
|
- | 547 | -> LocalURI |
|
- | 548 | -> Undo URIMode |
|
- | 549 | -> ExceptT Text Handler Text |
|
- | 550 | undoF |
|
- | 551 | recipRoute getRecip recipInbox recipFollowers trySubObjects |
|
- | 552 | now author body mfwd luUndo (Undo luObj) = do |
|
- | 553 | lift $ runDB $ do |
|
- | 554 | Entity idRecip recip <- getRecip |
|
- | 555 | ractid <- insertActivity luUndo |
|
- | 556 | mreason <- deleteRemoteFollow idRecip (recipFollowers recip) |
|
- | 557 | case mreason of |
|
- | 558 | Just reason -> return $ "Not using this Undo: " <> reason |
|
- | 559 | Nothing -> do |
|
- | 560 | inserted <- insertToInbox (recipInbox recip) ractid |
|
- | 561 | encodeRouteLocal <- getEncodeRouteLocal |
|
- | 562 | let me = localUriPath $ encodeRouteLocal recipRoute |
|
- | 563 | return $ |
|
- | 564 | if inserted |
|
- | 565 | then "Undo applied and inserted to inbox of " <> me |
|
- | 566 | else "Undo applied and already exists in inbox of " <> me |
|
+ | 538 | getFollow (Left _) = return Nothing |
|
+ | 539 | getFollow (Right ractid) = getBy $ UniqueRemoteFollowFollow ractid |
|
+ | 540 | ||
+ | 541 | getResolve (Left (_, obiid)) = fmap Left <$> getBy (UniqueTicketResolveLocalActivity obiid) |
|
+ | 542 | getResolve (Right ractid) = fmap Right <$> getBy (UniqueTicketResolveRemoteActivity ractid) |
|
+ | 543 | ||
+ | 544 | deleteResolve myWorkItem prepareAccept tr = do |
|
+ | 545 | let (trid, trxid) = |
|
+ | 546 | case tr of |
|
+ | 547 | Left (Entity trlid trl) -> (ticketResolveLocalTicket trl, Left trlid) |
|
+ | 548 | Right (Entity trrid trr) -> (ticketResolveRemoteTicket trr, Right trrid) |
|
+ | 549 | ltid <- ticketResolveTicket <$> getJust trid |
|
+ | 550 | wi <- getWorkItem ltid |
|
+ | 551 | case myWorkItem wi of |
|
+ | 552 | Nothing -> return ("Undo is of a TicketResolve but not my ticket", Nothing, Nothing) |
|
+ | 553 | Just wiData -> do |
|
+ | 554 | bitraverse delete delete trxid |
|
+ | 555 | delete trid |
|
+ | 556 | (colls, accept) <- prepareAccept wiData |
|
+ | 557 | return ("Ticket unresolved", Just colls, Just accept) |
|
+ | 558 | ||
+ | 559 | deleteRemoteFollow myWorkItem author fsidRecip (Entity rfid rf) |
|
+ | 560 | | remoteFollowActor rf /= remoteAuthorId author = |
|
+ | 561 | return "Undo sent by different actor than the one who sent the Follow" |
|
+ | 562 | | remoteFollowTarget rf == fsidRecip = do |
|
+ | 563 | delete rfid |
|
+ | 564 | return "Undo applied to sharer RemoteFollow" |
|
+ | 565 | | otherwise = do |
|
+ | 566 | r <- tryTicket $ remoteFollowTarget rf |
|
+ | 567 | when (isRight r) $ delete rfid |
|
+ | 568 | return $ either id id r |
|
- | 569 | insertActivity luUndo = do |
|
- | 570 | let iidAuthor = remoteAuthorInstance author |
|
- | 571 | roid <- |
|
- | 572 | either entityKey id <$> insertBy' (RemoteObject iidAuthor luUndo) |
|
- | 573 | let jsonObj = persistJSONFromBL $ actbBL body |
|
- | 574 | ract = RemoteActivity roid jsonObj now |
|
- | 575 | either entityKey id <$> insertBy' ract |
|
- | 576 | deleteRemoteFollow idRecip fsidRecip = do |
|
- | 577 | let iidAuthor = remoteAuthorInstance author |
|
- | 578 | mractidObj <- runMaybeT $ do |
|
- | 579 | roid <- MaybeT $ getKeyBy $ UniqueRemoteObject iidAuthor luObj |
|
- | 580 | MaybeT $ getKeyBy $ UniqueRemoteActivity roid |
|
- | 581 | case mractidObj of |
|
- | 582 | Nothing -> return $ Just "Undo object isn't a known activity" |
|
- | 583 | Just ractidObj -> do |
|
- | 584 | merf <- getBy $ UniqueRemoteFollowFollow ractidObj |
|
- | 585 | case merf of |
|
- | 586 | Nothing -> return $ Just "Undo object doesn't match an active RemoteFollow" |
|
- | 587 | Just (Entity rfid rf) |
|
- | 588 | | remoteFollowActor rf /= remoteAuthorId author -> |
|
- | 589 | return $ Just "Undo sent by different actor than the one who sent the Follow" |
|
- | 590 | | remoteFollowTarget rf == fsidRecip -> do |
|
- | 591 | delete rfid |
|
- | 592 | return Nothing |
|
- | 593 | | otherwise -> do |
|
- | 594 | mr <- trySubObjects idRecip (remoteFollowTarget rf) |
|
- | 595 | when (isNothing mr) $ delete rfid |
|
- | 596 | return mr |
|
- | 597 | insertToInbox ibidRecip ractid = do |
|
- | 598 | ibiid <- insert $ InboxItem False |
|
- | 599 | mibrid <- insertUnique $ InboxItemRemote ibidRecip ractid ibiid |
|
- | 600 | case mibrid of |
|
- | 601 | Nothing -> do |
|
- | 602 | delete ibiid |
|
- | 603 | return False |
|
- | 604 | Just _ -> return True |
|
- | 605 | ||
- | 606 | sharerUndoF |
|
- | 607 | :: ShrIdent |
|
- | 608 | -> UTCTime |
|
- | 609 | -> RemoteAuthor |
|
- | 610 | -> ActivityBody |
|
- | 611 | -> Maybe (LocalRecipientSet, ByteString) |
|
- | 612 | -> LocalURI |
|
- | 613 | -> Undo URIMode |
|
- | 614 | -> ExceptT Text Handler Text |
|
- | 615 | sharerUndoF shr = |
|
- | 616 | undoF |
|
- | 617 | (SharerR shr) |
|
- | 618 | getRecip |
|
- | 619 | personInbox |
|
- | 620 | personFollowers |
|
- | 621 | tryTicket |
|
- | 622 | where |
|
- | 623 | getRecip = do |
|
- | 624 | sid <- getKeyBy404 $ UniqueSharer shr |
|
- | 625 | getBy404 $ UniquePersonIdent sid |
|
- | 626 | tryTicket pid fsid = do |
|
+ | 571 | tryTicket fsid = do |
|
- | 572 | Nothing -> return $ Just "Undo object is a RemoteFollow, but isn't under this sharer" |
|
+ | 517 | Nothing -> return $ Left "Undo object is a RemoteFollow, but not for me and not for a ticket" |
|
- | 574 | mtal <- getBy $ UniqueTicketAuthorLocal ltid |
|
- | 575 | case mtal of |
|
- | 576 | Just (Entity talid tal) |
|
- | 577 | | ticketAuthorLocalAuthor tal == pid -> do |
|
- | 578 | mtup <- getBy $ UniqueTicketUnderProjectAuthor talid |
|
- | 579 | return $ |
|
- | 580 | case mtup of |
|
- | 581 | Nothing -> Nothing |
|
- | 582 | Just _ -> Just "Undo object is a RemoteFollow of a ticket authored by this sharer, but is hosted by the project" |
|
- | 583 | _ -> return $ Just "Undo object is a RemoteFollow of a ticket of another author" |
|
+ | 519 | wi <- getWorkItem ltid |
|
+ | 520 | return $ |
|
+ | 521 | if myWorkItem wi |
|
+ | 522 | then Right "Undo applied to RemoteFollow of my ticket" |
|
+ | 523 | else Left "Undo is of RemoteFollow of a ticket that isn't mine" |
|
+ | 524 | ||
+ | 525 | insertAcceptOnUndo actor author luUndo obiid auds = do |
|
+ | 526 | encodeRouteLocal <- getEncodeRouteLocal |
|
+ | 527 | encodeRouteHome <- getEncodeRouteHome |
|
+ | 528 | hLocal <- asksSite siteInstanceHost |
|
+ | 529 | obikhid <- encodeKeyHashid obiid |
|
+ | 530 | let hAuthor = objUriAuthority $ remoteAuthorURI author |
|
+ | 531 | ||
+ | 532 | (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = |
|
+ | 533 | collectAudience auds |
|
+ | 534 | ||
+ | 535 | recips = map encodeRouteHome audLocal ++ audRemote |
|
+ | 536 | doc = Doc hLocal Activity |
|
+ | 537 | { activityId = |
|
+ | 538 | Just $ encodeRouteLocal $ actorOutboxItem actor obikhid |
|
+ | 539 | , activityActor = encodeRouteLocal $ renderLocalActor actor |
|
+ | 540 | , activitySummary = Nothing |
|
+ | 541 | , activityAudience = Audience recips [] [] [] [] [] |
|
+ | 542 | , activitySpecific = AcceptActivity Accept |
|
+ | 543 | { acceptObject = ObjURI hAuthor luUndo |
|
+ | 544 | , acceptResult = Nothing |
|
+ | 545 | } |
|
+ | 546 | } |
|
+ | 547 | update obiid [OutboxItemActivity =. persistJSONObjectFromDoc doc] |
|
+ | 548 | return (doc, recipientSet, remoteActors, fwdHosts) |
|
+ | 549 | where |
|
+ | 550 | actorOutboxItem (LocalActorSharer shr) = SharerOutboxItemR shr |
|
+ | 551 | actorOutboxItem (LocalActorProject shr prj) = ProjectOutboxItemR shr prj |
|
+ | 552 | actorOutboxItem (LocalActorRepo shr rp) = RepoOutboxItemR shr rp |
|
+ | 553 | ||
+ | 554 | sharerUndoF |
|
+ | 555 | :: ShrIdent |
|
+ | 556 | -> UTCTime |
|
+ | 557 | -> RemoteAuthor |
|
+ | 558 | -> ActivityBody |
|
+ | 559 | -> Maybe (LocalRecipientSet, ByteString) |
|
+ | 560 | -> LocalURI |
|
+ | 561 | -> Undo URIMode |
|
+ | 562 | -> ExceptT Text Handler Text |
|
+ | 563 | sharerUndoF shrRecip now author body mfwd luUndo (Undo uObj) = do |
|
+ | 564 | object <- parseActivity uObj |
|
+ | 565 | mmmhttp <- runDBExcept $ do |
|
+ | 566 | p <- lift $ do |
|
+ | 567 | sid <- getKeyBy404 $ UniqueSharer shrRecip |
|
+ | 568 | getValBy404 $ UniquePersonIdent sid |
|
+ | 569 | mractid <- lift $ insertToInbox now author body (personInbox p) luUndo True |
|
+ | 570 | for mractid $ \ ractid -> do |
|
+ | 571 | mobject' <- getActivity object |
|
+ | 572 | lift $ for mobject' $ \ object' -> do |
|
+ | 573 | mobject'' <- runMaybeT $ |
|
+ | 574 | Left <$> MaybeT (getFollow object') <|> |
|
+ | 575 | Right <$> MaybeT (getResolve object') |
|
+ | 576 | for mobject'' $ \ object'' -> do |
|
+ | 577 | (result, mfwdColl, macceptAuds) <- |
|
+ | 578 | case object'' of |
|
+ | 579 | Left erf -> (,Nothing,Nothing) <$> deleteRemoteFollow (isJust . myWorkItem) author (personFollowers p) erf |
|
+ | 580 | Right tr -> deleteResolve myWorkItem prepareAccept tr |
|
+ | 581 | mremotesHttpFwd <- for (liftA2 (,) mfwd mfwdColl) $ \ ((localRecips, sig), colls) -> do |
|
+ | 582 | let sieve = makeRecipientSet [] colls |
|
+ | 583 | remoteRecips <- |
|
+ | 584 | insertRemoteActivityToLocalInboxes |
|
+ | 585 | False ractid $ |
|
+ | 586 | localRecipSieve' |
|
+ | 587 | sieve False False localRecips |
|
+ | 588 | (sig,) <$> deliverRemoteDB_S (actbBL body) ractid (personIdent p) sig remoteRecips |
|
+ | 589 | mremotesHttpAccept <- for macceptAuds $ \ acceptAuds -> do |
|
+ | 590 | obiidAccept <- insertEmptyOutboxItem (personOutbox p) now |
|
+ | 591 | (docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <- |
|
+ | 592 | insertAcceptOnUndo (LocalActorSharer shrRecip) author luUndo obiidAccept acceptAuds |
|
+ | 593 | knownRemoteRecipsAccept <- |
|
+ | 594 | deliverLocal' |
|
+ | 595 | False |
|
+ | 596 | (LocalActorSharer shrRecip) |
|
+ | 597 | (personInbox p) |
|
+ | 598 | obiidAccept |
|
+ | 599 | localRecipsAccept |
|
+ | 600 | (obiidAccept,docAccept,fwdHostsAccept,) <$> |
|
+ | 601 | deliverRemoteDB'' fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept |
|
+ | 602 | return (result, mremotesHttpFwd, mremotesHttpAccept) |
|
+ | 603 | case mmmhttp of |
|
+ | 604 | Nothing -> return "Activity already in my inbox" |
|
+ | 605 | Just mmhttp -> |
|
+ | 606 | case mmhttp of |
|
+ | 607 | Nothing -> return "Undo object isn't a known activity" |
|
+ | 608 | Just mhttp -> |
|
+ | 609 | case mhttp of |
|
+ | 610 | Nothing -> return "Undo object isn't in use" |
|
+ | 611 | Just (msg, mremotesHttpFwd, mremotesHttpAccept) -> do |
|
+ | 612 | for_ mremotesHttpFwd $ \ (sig, remotes) -> |
|
+ | 613 | forkWorker "sharerUndoF inbox-forwarding" $ |
|
+ | 614 | deliverRemoteHTTP_S now shrRecip (actbBL body) sig remotes |
|
+ | 615 | for_ mremotesHttpAccept $ \ (obiid, doc, fwdHosts, remotes) -> |
|
+ | 616 | forkWorker "sharerUndoF Accept HTTP delivery" $ |
|
+ | 617 | deliverRemoteHttp' fwdHosts obiid doc remotes |
|
+ | 618 | let fwdMsg = |
|
+ | 619 | case mremotesHttpFwd of |
|
+ | 620 | Nothing -> "No inbox-forwarding" |
|
+ | 621 | Just _ -> "Did inbox-forwarding" |
|
+ | 622 | acceptMsg = |
|
+ | 623 | case mremotesHttpAccept of |
|
+ | 624 | Nothing -> "Didn't send Accept" |
|
+ | 625 | Just _ -> "Sent Accept" |
|
+ | 626 | return $ msg <> "; " <> fwdMsg <> "; " <> acceptMsg |
|
+ | 627 | where |
|
+ | 628 | myWorkItem (WorkItemSharerTicket shr talid patch) |
|
+ | 629 | | shr == shrRecip = Just (talid, patch) |
|
+ | 630 | myWorkItem _ = Nothing |
|
+ | 631 | ||
+ | 632 | prepareAccept (talid, patch) = do |
|
+ | 633 | talkhid <- encodeKeyHashid talid |
|
+ | 634 | ra <- getJust $ remoteAuthorId author |
|
+ | 635 | let ObjURI hAuthor luAuthor = remoteAuthorURI author |
|
+ | 636 | ticketFollowers = |
|
+ | 637 | if patch |
|
+ | 638 | then LocalPersonCollectionSharerPatchFollowers shrRecip talkhid |
|
+ | 639 | else LocalPersonCollectionSharerTicketFollowers shrRecip talkhid |
|
+ | 640 | audAuthor = |
|
+ | 641 | AudRemote hAuthor [luAuthor] (maybeToList $ remoteActorFollowers ra) |
|
+ | 642 | audTicket = |
|
+ | 643 | AudLocal [] [ticketFollowers] |
|
+ | 644 | return ([ticketFollowers], [audAuthor, audTicket]) |
|
… | … | … | … |
- | 711 | projectUndoF shr prj = |
|
- | 712 | undoF |
|
- | 713 | (ProjectR shr prj) |
|
- | 714 | getRecip |
|
- | 715 | projectInbox |
|
- | 716 | projectFollowers |
|
- | 717 | tryTicket |
|
+ | 772 | projectUndoF shrRecip prjRecip now author body mfwd luUndo (Undo uObj) = do |
|
+ | 773 | object <- parseActivity uObj |
|
+ | 774 | mmmhttp <- runDBExcept $ do |
|
+ | 775 | Entity jid j <- lift $ do |
|
+ | 776 | sid <- getKeyBy404 $ UniqueSharer shrRecip |
|
+ | 777 | getBy404 $ UniqueProject prjRecip sid |
|
+ | 778 | mractid <- lift $ insertToInbox now author body (projectInbox j) luUndo False |
|
+ | 779 | for mractid $ \ ractid -> do |
|
+ | 780 | mobject' <- getActivity object |
|
+ | 781 | lift $ for mobject' $ \ object' -> do |
|
+ | 782 | mobject'' <- runMaybeT $ |
|
+ | 783 | Left <$> MaybeT (getFollow object') <|> |
|
+ | 784 | Right <$> MaybeT (getResolve object') |
|
+ | 785 | for mobject'' $ \ object'' -> do |
|
+ | 786 | (result, mfwdColl, macceptAuds) <- |
|
+ | 787 | case object'' of |
|
+ | 788 | Left erf -> (,Nothing,Nothing) <$> deleteRemoteFollow (isJust . myWorkItem) author (projectFollowers j) erf |
|
+ | 789 | Right tr -> deleteResolve myWorkItem prepareAccept tr |
|
+ | 790 | mremotesHttpFwd <- for (liftA2 (,) mfwd mfwdColl) $ \ ((localRecips, sig), colls) -> do |
|
+ | 791 | let sieve = makeRecipientSet [] colls |
|
+ | 792 | remoteRecips <- |
|
+ | 793 | insertRemoteActivityToLocalInboxes |
|
+ | 794 | False ractid $ |
|
+ | 795 | localRecipSieve' |
|
+ | 796 | sieve False False localRecips |
|
+ | 797 | (sig,) <$> deliverRemoteDB_J (actbBL body) ractid jid sig remoteRecips |
|
+ | 798 | mremotesHttpAccept <- for macceptAuds $ \ acceptAuds -> do |
|
+ | 799 | obiidAccept <- insertEmptyOutboxItem (projectOutbox j) now |
|
+ | 800 | (docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <- |
|
+ | 801 | insertAcceptOnUndo (LocalActorProject shrRecip prjRecip) author luUndo obiidAccept acceptAuds |
|
+ | 802 | knownRemoteRecipsAccept <- |
|
+ | 803 | deliverLocal' |
|
+ | 804 | False |
|
+ | 805 | (LocalActorProject shrRecip prjRecip) |
|
+ | 806 | (projectInbox j) |
|
+ | 807 | obiidAccept |
|
+ | 808 | localRecipsAccept |
|
+ | 809 | (obiidAccept,docAccept,fwdHostsAccept,) <$> |
|
+ | 810 | deliverRemoteDB'' fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept |
|
+ | 811 | return (result, mremotesHttpFwd, mremotesHttpAccept) |
|
+ | 812 | case mmmhttp of |
|
+ | 813 | Nothing -> return "Activity already in my inbox" |
|
+ | 814 | Just mmhttp -> |
|
+ | 815 | case mmhttp of |
|
+ | 816 | Nothing -> return "Undo object isn't a known activity" |
|
+ | 817 | Just mhttp -> |
|
+ | 818 | case mhttp of |
|
+ | 819 | Nothing -> return "Undo object isn't in use" |
|
+ | 820 | Just (msg, mremotesHttpFwd, mremotesHttpAccept) -> do |
|
+ | 821 | for_ mremotesHttpFwd $ \ (sig, remotes) -> |
|
+ | 822 | forkWorker "projectUndoF inbox-forwarding" $ |
|
+ | 823 | deliverRemoteHTTP_J now shrRecip prjRecip (actbBL body) sig remotes |
|
+ | 824 | for_ mremotesHttpAccept $ \ (obiid, doc, fwdHosts, remotes) -> |
|
+ | 825 | forkWorker "projectUndoF Accept HTTP delivery" $ |
|
+ | 826 | deliverRemoteHttp' fwdHosts obiid doc remotes |
|
+ | 827 | let fwdMsg = |
|
+ | 828 | case mremotesHttpFwd of |
|
+ | 829 | Nothing -> "No inbox-forwarding" |
|
+ | 830 | Just _ -> "Did inbox-forwarding" |
|
+ | 831 | acceptMsg = |
|
+ | 832 | case mremotesHttpAccept of |
|
+ | 833 | Nothing -> "Didn't send Accept" |
|
+ | 834 | Just _ -> "Sent Accept" |
|
+ | 835 | return $ msg <> "; " <> fwdMsg <> "; " <> acceptMsg |
|
… | … | … | … |
- | 776 | getRecip = do |
|
- | 777 | sid <- getKeyBy404 $ UniqueSharer shr |
|
- | 778 | getBy404 $ UniqueProject prj sid |
|
- | 779 | tryTicket jid fsid = do |
|
- | 780 | mlt <- getValBy $ UniqueLocalTicketFollowers fsid |
|
- | 781 | case mlt of |
|
- | 782 | Nothing -> return $ Just "Undo object is a RemoteFollow, but isn't under this project" |
|
- | 783 | Just lt -> do |
|
- | 784 | mtpl <- runMaybeT $ do |
|
- | 785 | tclid <- MaybeT $ getKeyBy $ UniqueTicketContextLocal $ localTicketTicket lt |
|
- | 786 | tpl <- MaybeT $ getValBy $ UniqueTicketProjectLocal tclid |
|
- | 787 | return (tclid, tpl) |
|
- | 788 | case mtpl of |
|
- | 789 | Just (tclid, tpl) |
|
- | 790 | | ticketProjectLocalProject tpl == jid -> do |
|
- | 791 | mtup <- getBy $ UniqueTicketUnderProjectProject tclid |
|
- | 792 | return $ |
|
- | 793 | case mtup of |
|
- | 794 | Nothing -> Just "Undo object is a RemoteFollow of a ticket under this project, but is hosted by the author" |
|
- | 795 | Just _ -> Nothing |
|
- | 796 | _ -> return $ Just "Undo object is a RemoteFollow of a ticket of another project" |
|
+ | 894 | myWorkItem (WorkItemProjectTicket shr prj ltid) |
|
+ | 895 | | shr == shrRecip && prj == prjRecip = Just ltid |
|
+ | 896 | myWorkItem _ = Nothing |
|
+ | 897 | ||
+ | 898 | prepareAccept ltid = do |
|
+ | 899 | ltkhid <- encodeKeyHashid ltid |
|
+ | 900 | ra <- getJust $ remoteAuthorId author |
|
+ | 901 | let ObjURI hAuthor luAuthor = remoteAuthorURI author |
|
+ | 902 | ticketFollowers = |
|
+ | 903 | LocalPersonCollectionProjectTicketFollowers shrRecip prjRecip ltkhid |
|
+ | 904 | audAuthor = |
|
+ | 905 | AudRemote hAuthor [luAuthor] (maybeToList $ remoteActorFollowers ra) |
|
+ | 906 | audTicket = |
|
+ | 907 | AudLocal [] [ticketFollowers] |
|
+ | 908 | return ([ticketFollowers], [audAuthor, audTicket]) |
|
- | 802 | repoUndoF shr rp = |
|
- | 803 | undoF |
|
- | 804 | (RepoR shr rp) |
|
- | 805 | getRecip |
|
- | 806 | repoInbox |
|
- | 807 | repoFollowers |
|
- | 808 | tryPatch |
|
+ | 914 | repoUndoF shrRecip rpRecip now author body mfwd luUndo (Undo uObj) = do |
|
+ | 915 | object <- parseActivity uObj |
|
+ | 916 | mmmhttp <- runDBExcept $ do |
|
+ | 917 | Entity rid r <- lift $ do |
|
+ | 918 | sid <- getKeyBy404 $ UniqueSharer shrRecip |
|
+ | 919 | getBy404 $ UniqueRepo rpRecip sid |
|
+ | 920 | mractid <- lift $ insertToInbox now author body (repoInbox r) luUndo False |
|
+ | 921 | for mractid $ \ ractid -> do |
|
+ | 922 | mobject' <- getActivity object |
|
+ | 923 | lift $ for mobject' $ \ object' -> do |
|
+ | 924 | mobject'' <- runMaybeT $ |
|
+ | 925 | Left <$> MaybeT (getFollow object') <|> |
|
+ | 926 | Right <$> MaybeT (getResolve object') |
|
+ | 927 | for mobject'' $ \ object'' -> do |
|
+ | 928 | (result, mfwdColl, macceptAuds) <- |
|
+ | 929 | case object'' of |
|
+ | 930 | Left erf -> (,Nothing,Nothing) <$> deleteRemoteFollow (isJust . myWorkItem) author (repoFollowers r) erf |
|
+ | 931 | Right tr -> deleteResolve myWorkItem prepareAccept tr |
|
+ | 932 | mremotesHttpFwd <- for (liftA2 (,) mfwd mfwdColl) $ \ ((localRecips, sig), colls) -> do |
|
+ | 933 | let sieve = makeRecipientSet [] colls |
|
+ | 934 | remoteRecips <- |
|
+ | 935 | insertRemoteActivityToLocalInboxes |
|
+ | 936 | False ractid $ |
|
+ | 937 | localRecipSieve' |
|
+ | 938 | sieve False False localRecips |
|
+ | 939 | (sig,) <$> deliverRemoteDB_R (actbBL body) ractid rid sig remoteRecips |
|
+ | 940 | mremotesHttpAccept <- for macceptAuds $ \ acceptAuds -> do |
|
+ | 941 | obiidAccept <- insertEmptyOutboxItem (repoOutbox r) now |
|
+ | 942 | (docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <- |
|
+ | 943 | insertAcceptOnUndo (LocalActorRepo shrRecip rpRecip) author luUndo obiidAccept acceptAuds |
|
+ | 944 | knownRemoteRecipsAccept <- |
|
+ | 945 | deliverLocal' |
|
+ | 946 | False |
|
+ | 947 | (LocalActorRepo shrRecip rpRecip) |
|
+ | 948 | (repoInbox r) |
|
+ | 949 | obiidAccept |
|
+ | 950 | localRecipsAccept |
|
+ | 951 | (obiidAccept,docAccept,fwdHostsAccept,) <$> |
|
+ | 952 | deliverRemoteDB'' fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept |
|
+ | 953 | return (result, mremotesHttpFwd, mremotesHttpAccept) |
|
+ | 954 | case mmmhttp of |
|
+ | 955 | Nothing -> return "Activity already in my inbox" |
|
+ | 956 | Just mmhttp -> |
|
+ | 957 | case mmhttp of |
|
+ | 958 | Nothing -> return "Undo object isn't a known activity" |
|
+ | 959 | Just mhttp -> |
|
+ | 960 | case mhttp of |
|
+ | 961 | Nothing -> return "Undo object isn't in use" |
|
+ | 962 | Just (msg, mremotesHttpFwd, mremotesHttpAccept) -> do |
|
+ | 963 | for_ mremotesHttpFwd $ \ (sig, remotes) -> |
|
+ | 964 | forkWorker "repoUndoF inbox-forwarding" $ |
|
+ | 965 | deliverRemoteHTTP_R now shrRecip rpRecip (actbBL body) sig remotes |
|
+ | 966 | for_ mremotesHttpAccept $ \ (obiid, doc, fwdHosts, remotes) -> |
|
+ | 967 | forkWorker "repoUndoF Accept HTTP delivery" $ |
|
+ | 968 | deliverRemoteHttp' fwdHosts obiid doc remotes |
|
+ | 969 | let fwdMsg = |
|
+ | 970 | case mremotesHttpFwd of |
|
+ | 971 | Nothing -> "No inbox-forwarding" |
|
+ | 972 | Just _ -> "Did inbox-forwarding" |
|
+ | 973 | acceptMsg = |
|
+ | 974 | case mremotesHttpAccept of |
|
+ | 975 | Nothing -> "Didn't send Accept" |
|
+ | 976 | Just _ -> "Sent Accept" |
|
+ | 977 | return $ msg <> "; " <> fwdMsg <> "; " <> acceptMsg |
|
… | … | … | … |
- | 867 | getRecip = do |
|
- | 868 | sid <- getKeyBy404 $ UniqueSharer shr |
|
- | 869 | getBy404 $ UniqueRepo rp sid |
|
- | 870 | tryPatch rid fsid = do |
|
- | 871 | mlt <- getValBy $ UniqueLocalTicketFollowers fsid |
|
- | 872 | case mlt of |
|
- | 873 | Nothing -> return $ Just "Undo object is a RemoteFollow, but isn't under this repo" |
|
- | 874 | Just lt -> do |
|
- | 875 | mtrl <- runMaybeT $ do |
|
- | 876 | tclid <- MaybeT $ getKeyBy $ UniqueTicketContextLocal $ localTicketTicket lt |
|
- | 877 | trl <- MaybeT $ getValBy $ UniqueTicketRepoLocal tclid |
|
- | 878 | return (tclid, trl) |
|
- | 879 | case mtrl of |
|
- | 880 | Just (tclid, trl) |
|
- | 881 | | ticketRepoLocalRepo trl == rid -> do |
|
- | 882 | mtup <- getBy $ UniqueTicketUnderProjectProject tclid |
|
- | 883 | return $ |
|
- | 884 | case mtup of |
|
- | 885 | Nothing -> Just "Undo object is a RemoteFollow of a patch under this repo, but is hosted by the author" |
|
- | 886 | Just _ -> Nothing |
|
- | 887 | _ -> return $ Just "Undo object is a RemoteFollow of a ticket of another project" |
|
+ | 1036 | myWorkItem (WorkItemRepoPatch shr rp ltid) |
|
+ | 1037 | | shr == shrRecip && rp == rpRecip = Just ltid |
|
+ | 1038 | myWorkItem _ = Nothing |
|
+ | 1039 | ||
+ | 1040 | prepareAccept ltid = do |
|
+ | 1041 | ltkhid <- encodeKeyHashid ltid |
|
+ | 1042 | ra <- getJust $ remoteAuthorId author |
|
+ | 1043 | let ObjURI hAuthor luAuthor = remoteAuthorURI author |
|
+ | 1044 | ticketFollowers = |
|
+ | 1045 | LocalPersonCollectionRepoPatchFollowers shrRecip rpRecip ltkhid |
|
+ | 1046 | audAuthor = |
|
+ | 1047 | AudRemote hAuthor [luAuthor] (maybeToList $ remoteActorFollowers ra) |
|
+ | 1048 | audTicket = |
|
+ | 1049 | AudLocal [] [ticketFollowers] |
|
+ | 1050 | return ([ticketFollowers], [audAuthor, audTicket]) |
|
… | … | … | … |
Edit file src/Vervis/Federation/Ticket.hs 0 → 0
- | 259 | , ticketClosed = UTCTime (ModifiedJulianDay 0) 0 |
|
- | 260 | , ticketCloser = Nothing |
|
… | … | … | … |
- | 805 | , ticketClosed = UTCTime (ModifiedJulianDay 0) 0 |
|
- | 806 | , ticketCloser = Nothing |
|
… | … | … | … |
Edit file src/Vervis/Form/Ticket.hs 0 → 0
- | 159 | <*> pure (ticketClosed ticket) |
|
- | 160 | <*> pure (ticketCloser ticket) |
|
… | … | … | … |
Edit file src/Vervis/Handler/Client.hs 0 → 0
+ | 37 | , postProjectTicketCloseR |
|
+ | 38 | , postProjectTicketOpenR |
|
… | … | … | … |
+ | 97 | import Vervis.Ticket |
|
… | … | … | … |
+ | 253 | getUser' :: Handler (Entity Person, Sharer) |
|
+ | 254 | getUser' = do |
|
+ | 255 | ep@(Entity _ p) <- requireVerifiedAuth |
|
+ | 256 | s <- runDB $ getJust $ personIdent p |
|
+ | 257 | return (ep, s) |
|
+ | 258 | ||
… | … | … | … |
+ | 326 | ResolveActivity resolve -> |
|
+ | 327 | resolveC eperson sharer summary audience resolve |
|
- | 320 | undoC shr summary audience undo |
|
+ | 331 | undoC eperson sharer summary audience undo |
|
… | … | … | … |
- | 586 | (shrAuthor, pidAuthor) <- getUser |
|
+ | 597 | (ep@(Entity pid _), s) <- getUser' |
|
+ | 598 | let shrAuthor = sharerIdent s |
|
- | 590 | ExceptT $ undoFollowSharer shrAuthor pidAuthor shrFollowee |
|
- | 591 | undoC shrAuthor (Just summary) audience undo |
|
+ | 602 | ExceptT $ undoFollowSharer shrAuthor pid shrFollowee |
|
+ | 603 | undoC ep s (Just summary) audience undo |
|
- | 597 | (shrAuthor, pidAuthor) <- getUser |
|
+ | 609 | (ep@(Entity pid _), s) <- getUser' |
|
+ | 610 | let shrAuthor = sharerIdent s |
|
- | 601 | ExceptT $ undoFollowProject shrAuthor pidAuthor shrFollowee prjFollowee |
|
- | 602 | undoC shrAuthor (Just summary) audience undo |
|
+ | 614 | ExceptT $ undoFollowProject shrAuthor pid shrFollowee prjFollowee |
|
+ | 615 | undoC ep s (Just summary) audience undo |
|
- | 608 | (shrAuthor, pidAuthor) <- getUser |
|
+ | 621 | (ep@(Entity pid _), s) <- getUser' |
|
+ | 622 | let shrAuthor = sharerIdent s |
|
- | 612 | ExceptT $ undoFollowTicket shrAuthor pidAuthor shrFollowee prjFollowee tkhidFollowee |
|
- | 613 | undoC shrAuthor (Just summary) audience undo |
|
+ | 626 | ExceptT $ undoFollowTicket shrAuthor pid shrFollowee prjFollowee tkhidFollowee |
|
+ | 627 | undoC ep s (Just summary) audience undo |
|
- | 619 | (shrAuthor, pidAuthor) <- getUser |
|
+ | 633 | (ep@(Entity pid _), s) <- getUser' |
|
+ | 634 | let shrAuthor = sharerIdent s |
|
- | 623 | ExceptT $ undoFollowRepo shrAuthor pidAuthor shrFollowee rpFollowee |
|
- | 624 | undoC shrAuthor (Just summary) audience undo |
|
+ | 638 | ExceptT $ undoFollowRepo shrAuthor pid shrFollowee rpFollowee |
|
+ | 639 | undoC ep s (Just summary) audience undo |
|
… | … | … | … |
+ | 869 | ||
+ | 870 | postProjectTicketCloseR |
|
+ | 871 | :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html |
|
+ | 872 | postProjectTicketCloseR shr prj ltkhid = do |
|
+ | 873 | encodeRouteHome <- getEncodeRouteHome |
|
+ | 874 | ep@(Entity _ p) <- requireVerifiedAuth |
|
+ | 875 | s <- runDB $ getJust $ personIdent p |
|
+ | 876 | let uTicket = encodeRouteHome $ ProjectTicketR shr prj ltkhid |
|
+ | 877 | result <- runExceptT $ do |
|
+ | 878 | (summary, audience, specific) <- ExceptT $ resolve (sharerIdent s) uTicket |
|
+ | 879 | resolveC ep s summary audience specific |
|
+ | 880 | case result of |
|
+ | 881 | Left e -> setMessage $ toHtml $ "Error: " <> e |
|
+ | 882 | Right _obiid -> setMessage "Ticket closed" |
|
+ | 883 | redirect $ ProjectTicketR shr prj ltkhid |
|
+ | 884 | ||
+ | 885 | postProjectTicketOpenR |
|
+ | 886 | :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html |
|
+ | 887 | postProjectTicketOpenR shr prj ltkhid = do |
|
+ | 888 | ep@(Entity _ p) <- requireVerifiedAuth |
|
+ | 889 | ltid <- decodeKeyHashid404 ltkhid |
|
+ | 890 | s <- runDB $ getJust $ personIdent p |
|
+ | 891 | result <- runExceptT $ do |
|
+ | 892 | (summary, audience, specific) <- ExceptT $ unresolve (sharerIdent s) (WorkItemProjectTicket shr prj ltid) |
|
+ | 893 | undoC ep s summary audience specific |
|
+ | 894 | case result of |
|
+ | 895 | Left e -> setMessage $ toHtml $ "Error: " <> e |
|
+ | 896 | Right _obiid -> setMessage "Ticket reopened" |
|
+ | 897 | redirect $ ProjectTicketR shr prj ltkhid |
|
… | … | … | … |
Edit file src/Vervis/Handler/Ticket.hs 0 → 0
- | 26 | , postProjectTicketCloseR |
|
- | 27 | , postProjectTicketOpenR |
|
… | … | … | … |
- | 300 | author, massignee, mcloser, ticket, lticket, tparams, eparams, cparams) <- |
|
+ | 298 | author, massignee, ticket, lticket, tparams, eparams, cparams) <- |
|
… | … | … | … |
- | 328 | mcloser <- |
|
- | 329 | case ticketStatus ticket of |
|
- | 330 | TSClosed -> |
|
- | 331 | case ticketCloser ticket of |
|
- | 332 | Just pidCloser -> Just <$> do |
|
- | 333 | person <- getJust pidCloser |
|
- | 334 | getJust $ personIdent person |
|
- | 335 | Nothing -> error "Closer not set for closed ticket" |
|
- | 336 | _ -> |
|
- | 337 | case ticketCloser ticket of |
|
- | 338 | Just _ -> error "Closer set for open ticket" |
|
- | 339 | Nothing -> return Nothing |
|
- | 333 | , author', massignee, mcloser, ticket, lticket |
|
+ | 319 | , author', massignee, ticket, lticket |
|
… | … | … | … |
- | 504 | redirect $ ProjectTicketR shr prj ltkhid |
|
- | 505 | ||
- | 506 | postProjectTicketCloseR |
|
- | 507 | :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html |
|
- | 508 | postProjectTicketCloseR shr prj ltkhid = do |
|
- | 509 | pid <- requireAuthId |
|
- | 510 | now <- liftIO getCurrentTime |
|
- | 511 | succ <- runDB $ do |
|
- | 512 | (_es, _ej, Entity tid ticket, _elt, _etcl, _etpl, _author) <- getProjectTicket404 shr prj ltkhid |
|
- | 513 | case ticketStatus ticket of |
|
- | 514 | TSClosed -> return False |
|
- | 515 | _ -> do |
|
- | 516 | update tid |
|
- | 517 | [ TicketAssignee =. Nothing |
|
- | 518 | , TicketStatus =. TSClosed |
|
- | 519 | , TicketClosed =. now |
|
- | 520 | , TicketCloser =. Just pid |
|
- | 521 | ] |
|
- | 522 | return True |
|
- | 523 | setMessage $ |
|
- | 524 | if succ |
|
- | 525 | then "Ticket closed." |
|
- | 526 | else "Ticket is already closed." |
|
- | 527 | redirect $ ProjectTicketR shr prj ltkhid |
|
- | 528 | ||
- | 529 | postProjectTicketOpenR |
|
- | 530 | :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html |
|
- | 531 | postProjectTicketOpenR shr prj ltkhid = do |
|
- | 532 | pid <- requireAuthId |
|
- | 533 | now <- liftIO getCurrentTime |
|
- | 534 | succ <- runDB $ do |
|
- | 535 | (_es, _ej, Entity tid ticket, _elt, _etcl, _etpl, _author) <- getProjectTicket404 shr prj ltkhid |
|
- | 536 | case ticketStatus ticket of |
|
- | 537 | TSClosed -> do |
|
- | 538 | update tid |
|
- | 539 | [ TicketStatus =. TSTodo |
|
- | 540 | , TicketCloser =. Nothing |
|
- | 541 | ] |
|
- | 542 | return True |
|
- | 543 | _ -> return False |
|
- | 544 | setMessage $ |
|
- | 545 | if succ |
|
- | 546 | then "Ticket reopened" |
|
- | 547 | else "Ticket is already open." |
|
… | … | … | … |
Edit file src/Vervis/Migration.hs 0 → 0
+ | 1751 | -- 277 |
|
+ | 1752 | , removeField "Ticket" "closed" |
|
+ | 1753 | -- 278 |
|
+ | 1754 | , removeField "Ticket" "closer" |
|
… | … | … | … |
Edit file src/Vervis/WorkItem.hs 0 → 0
+ | 21 | , authorAudience |
|
… | … | … | … |
+ | 138 | authorAudience (Left shr) = AudLocal [LocalActorSharer shr] [] |
|
+ | 139 | authorAudience (Right (ObjURI h lu)) = AudRemote h [lu] [] |
|
+ | 140 | ||
… | … | … | … |
Edit file src/Web/ActivityPub.hs 0 → 0
- | 1347 | { undoObject :: LocalURI |
|
+ | 1347 | { undoObject :: ObjURI u |
|
- | 1351 | parseUndo a o = Undo <$> withAuthorityO a (o .: "object") |
|
+ | 1351 | parseUndo a o = Undo <$> o .: "object" |
|
- | 1354 | encodeUndo a (Undo obj) = "object" .= ObjURI a obj |
|
+ | 1354 | encodeUndo a (Undo obj) = "object" .= obj |
|
… | … | … | … |
Edit file src/Yesod/MonadSite.hs 0 → 0
+ | 31 | , runWorkerExcept |
|
… | … | … | … |
+ | 203 | runWorkerExcept action = do |
|
+ | 204 | site <- askSite |
|
+ | 205 | ExceptT $ liftIO $ runWorker (runExceptT action) site |
|
+ | 206 | ||
… | … | … | … |
Edit file templates/ticket/one.hamlet 0 → 0
- | 80 | Closed on #{showDate $ ticketClosed ticket} |
|
- | 81 | $maybe closer <- mcloser |
|
- | 82 | by ^{sharerLinkW closer}. |
|
+ | 80 | Closed on ___ by ___. |
|
… | … | … | … |