diff --git a/config/models b/config/models index 6451bf4..d2369e2 100644 --- a/config/models +++ b/config/models @@ -455,14 +455,44 @@ Patch created UTCTime content Text -TicketDependency - parent TicketId - child TicketId - author PersonId - summary Text -- HTML - created UTCTime +RemoteTicketDependency + ident RemoteObjectId + child LocalTicketId - UniqueTicketDependency parent child + UniqueRemoteTicketDependency ident + +LocalTicketDependency + parent LocalTicketId + created UTCTime + accept OutboxItemId + +TicketDependencyChildLocal + dep LocalTicketDependencyId + child LocalTicketId + + UniqueTicketDependencyChildLocal dep + +TicketDependencyChildRemote + dep LocalTicketDependencyId + child RemoteObjectId + + UniqueTicketDependencyChildRemote dep + +TicketDependencyAuthorLocal + dep LocalTicketDependencyId + author PersonId + open OutboxItemId + + UniqueTicketDependencyAuthorLocal dep + UniqueTicketDependencyAuthorLocalOpen open + +TicketDependencyAuthorRemote + dep LocalTicketDependencyId + author RemoteActorId + open RemoteActivityId + + UniqueTicketDependencyAuthorRemote dep + UniqueTicketDependencyAuthorRemoteOpen open TicketClaimRequest person PersonId diff --git a/migrations/2020_05_28_tda.model b/migrations/2020_05_28_tda.model new file mode 100644 index 0000000..3036add --- /dev/null +++ b/migrations/2020_05_28_tda.model @@ -0,0 +1,15 @@ +TicketDependencyAuthorLocal + dep TicketDependencyId + author PersonId + open OutboxItemId + + UniqueTicketDependencyAuthorLocal dep + UniqueTicketDependencyAuthorLocalOpen open + +TicketDependencyAuthorRemote + dep TicketDependencyId + author RemoteActorId + open RemoteActivityId + + UniqueTicketDependencyAuthorRemote dep + UniqueTicketDependencyAuthorRemoteOpen open diff --git a/migrations/2020_05_28_tda_mig.model b/migrations/2020_05_28_tda_mig.model new file mode 100644 index 0000000..6d73cb8 --- /dev/null +++ b/migrations/2020_05_28_tda_mig.model @@ -0,0 +1,39 @@ +Person + ident Int64 + login Text + passphraseHash ByteString + email Text + verified Bool + verifiedKey Text + verifiedKeyCreated UTCTime + resetPassKey Text + resetPassKeyCreated UTCTime + about Text + inbox Int64 + outbox OutboxId + followers Int64 + +Outbox + +OutboxItem + outbox OutboxId + activity PersistJSONObject + published UTCTime + +Ticket + +TicketDependency + parent TicketId + child TicketId + author PersonId + created UTCTime + + UniqueTicketDependency parent child + +TicketDependencyAuthorLocal + dep TicketDependencyId + author PersonId + open OutboxItemId + + UniqueTicketDependencyAuthorLocal dep + UniqueTicketDependencyAuthorLocalOpen open diff --git a/migrations/2020_06_01_tdc.model b/migrations/2020_06_01_tdc.model new file mode 100644 index 0000000..277db0e --- /dev/null +++ b/migrations/2020_06_01_tdc.model @@ -0,0 +1,17 @@ +TicketDependencyChildLocal + dep TicketDependencyId + child LocalTicketId + + UniqueTicketDependencyChildLocal dep + +TicketDependencyChildRemote + dep TicketDependencyId + child RemoteObjectId + + UniqueTicketDependencyChildRemote dep + +RemoteTicketDependency + ident RemoteObjectId + child LocalTicketId + + UniqueRemoteTicketDependency ident diff --git a/migrations/2020_06_01_tdc_mig.model b/migrations/2020_06_01_tdc_mig.model new file mode 100644 index 0000000..fbca6fc --- /dev/null +++ b/migrations/2020_06_01_tdc_mig.model @@ -0,0 +1,67 @@ +Discussion + +FollowerSet + +OutboxItem + +RemoteActor + +RemoteActivity + +RemoteObject + +RemoteDiscussion + +Ticket + +LocalTicket + ticket TicketId + discuss DiscussionId + followers FollowerSetId + + UniqueLocalTicket ticket + UniqueLocalTicketDiscussion discuss + UniqueLocalTicketFollowers followers + +TicketContextLocal + ticket TicketId + accept OutboxItemId + + UniqueTicketContextLocal ticket + UniqueTicketContextLocalAccept accept + +TicketAuthorRemote + ticket TicketContextLocalId + author RemoteActorId + open RemoteActivityId + + UniqueTicketAuthorRemote ticket + UniqueTicketAuthorRemoteOpen open + +RemoteTicket + ticket TicketAuthorRemoteId + ident RemoteObjectId + discuss RemoteDiscussionId + + UniqueRemoteTicket ticket + UniqueRemoteTicketIdent ident + UniqueRemoteTicketDiscuss discuss + +LocalTicketDependency + parent TicketId + child TicketId + created UTCTime + + UniqueLocalTicketDependency parent child + +TicketDependencyChildLocal + dep LocalTicketDependencyId + child LocalTicketId + + UniqueTicketDependencyChildLocal dep + +TicketDependencyChildRemote + dep LocalTicketDependencyId + child RemoteObjectId + + UniqueTicketDependencyChildRemote dep diff --git a/migrations/2020_06_02_tdp.model b/migrations/2020_06_02_tdp.model new file mode 100644 index 0000000..c1bdbf5 --- /dev/null +++ b/migrations/2020_06_02_tdp.model @@ -0,0 +1,30 @@ +Discussion + +FollowerSet + +Person + +Ticket + number Int Maybe + created UTCTime + title Text -- HTML + source Text -- Pandoc Markdown + description Text -- HTML + assignee PersonId Maybe + status Text + closed UTCTime + closer PersonId Maybe + +LocalTicket + ticket TicketId + discuss DiscussionId + followers FollowerSetId + + UniqueLocalTicket ticket + UniqueLocalTicketDiscussion discuss + UniqueLocalTicketFollowers followers + +LocalTicketDependency + parent TicketId + parentNew LocalTicketId + created UTCTime diff --git a/migrations/2020_06_15_td_accept.model b/migrations/2020_06_15_td_accept.model new file mode 100644 index 0000000..4d4d451 --- /dev/null +++ b/migrations/2020_06_15_td_accept.model @@ -0,0 +1,85 @@ +Outbox + +OutboxItem + outbox OutboxId + activity PersistJSONObject + published UTCTime + +Ticket + +Discussion + +FollowerSet + +Inbox + +Role + +Workflow + +Sharer + +Repo + +Person + +Project + ident PrjIdent + sharer SharerId + name Text Maybe + desc Text Maybe + workflow WorkflowId + nextTicket Int + wiki RepoId Maybe + collabUser RoleId Maybe + collabAnon RoleId Maybe + inbox InboxId + outbox OutboxId + followers FollowerSetId + + UniqueProject ident sharer + UniqueProjectInbox inbox + UniqueProjectOutbox outbox + UniqueProjectFollowers followers + +LocalTicket + ticket TicketId + discuss DiscussionId + followers FollowerSetId + + UniqueLocalTicket ticket + UniqueLocalTicketDiscussion discuss + UniqueLocalTicketFollowers followers + +TicketContextLocal + ticket TicketId + accept OutboxItemId + + UniqueTicketContextLocal ticket + UniqueTicketContextLocalAccept accept + +TicketProjectLocal + context TicketContextLocalId + project ProjectId + + UniqueTicketProjectLocal context + +TicketAuthorLocal + ticket LocalTicketId + author PersonId + open OutboxItemId + + UniqueTicketAuthorLocal ticket + UniqueTicketAuthorLocalOpen open + +TicketUnderProject + project TicketContextLocalId + author TicketAuthorLocalId + + UniqueTicketUnderProjectProject project + UniqueTicketUnderProjectAuthor author + +LocalTicketDependency + parent LocalTicketId + created UTCTime + accept OutboxItemId diff --git a/src/Network/FedURI.hs b/src/Network/FedURI.hs index bbcb80c..54d1974 100644 --- a/src/Network/FedURI.hs +++ b/src/Network/FedURI.hs @@ -184,7 +184,7 @@ instance PersistFieldSql FullURI where data LocalURI = LocalURI { localUriPath :: Text } - deriving (Eq, Generic) + deriving (Eq, Ord, Generic) instance Hashable LocalURI diff --git a/src/Vervis/API.hs b/src/Vervis/API.hs index 32e3c29..aeeef49 100644 --- a/src/Vervis/API.hs +++ b/src/Vervis/API.hs @@ -359,13 +359,6 @@ createNoteC (Entity pidUser personUser) sharerUser summary audience note = runEx sharerSet <- lookup shr localRecips repoSet <- lookup rp $ localRecipRepoRelated sharerSet guard $ localRecipRepo $ localRecipRepoDirect repoSet - insertEmptyOutboxItem obid now = do - h <- asksSite siteInstanceHost - insert OutboxItem - { outboxItemOutbox = obid - , outboxItemActivity = persistJSONObjectFromDoc $ Doc h emptyActivity - , outboxItemPublished = now - } getProject tpl = do j <- getJust $ ticketProjectLocalProject tpl s <- getJust $ projectSharer j @@ -1005,9 +998,10 @@ offerTicketC :: ShrIdent -> TextHtml -> Audience URIMode - -> Offer URIMode + -> AP.Ticket URIMode + -> FedURI -> Handler (Either Text OutboxItemId) -offerTicketC shrUser summary audience offer@(Offer ticket uTarget) = runExceptT $ do +offerTicketC shrUser summary audience ticket uTarget = runExceptT $ do (hProject, shrProject, prjProject) <- parseTarget uTarget {-deps <- -} checkOffer hProject shrProject prjProject @@ -1085,7 +1079,8 @@ offerTicketC shrUser summary audience offer@(Offer ticket uTarget) = runExceptT , activityActor = AP.ticketAttributedTo ticket , activitySummary = Just summary , activityAudience = audience - , activitySpecific = OfferActivity offer + , activitySpecific = + OfferActivity $ Offer (OfferTicket ticket) uTarget } obiid <- insert OutboxItem { outboxItemOutbox = obid diff --git a/src/Vervis/ActivityPub.hs b/src/Vervis/ActivityPub.hs index 625cf7b..3f64265 100644 --- a/src/Vervis/ActivityPub.hs +++ b/src/Vervis/ActivityPub.hs @@ -19,7 +19,6 @@ module Vervis.ActivityPub , verifyHostLocal , parseContext , parseParent - , runDBExcept , getLocalParentMessageId , getPersonOrGroupId , getTicketTeam @@ -43,13 +42,16 @@ module Vervis.ActivityPub --, checkDep , getProjectAndDeps , deliverRemoteDB' + , deliverRemoteDB'' , deliverRemoteHttp + , deliverRemoteHttp' , serveCommit , deliverLocal , RemoteRecipient (..) , deliverLocal' , insertRemoteActivityToLocalInboxes , provideEmptyCollection + , insertEmptyOutboxItem ) where @@ -194,20 +196,6 @@ parseParent uParent = do _ -> throwE "Local parent isn't a message route" else return $ Right uParent -newtype FedError = FedError Text deriving Show - -instance Exception FedError - -runDBExcept :: (MonadUnliftIO m, MonadSite m, SiteEnv m ~ App) => ExceptT Text (ReaderT SqlBackend m) a -> ExceptT Text m a -runDBExcept action = do - result <- - lift $ try $ runSiteDB $ either abort return =<< runExceptT action - case result of - Left (FedError t) -> throwE t - Right r -> return r - where - abort = liftIO . throwIO . FedError - getLocalParentMessageId :: DiscussionId -> ShrIdent -> LocalMessageId -> ExceptT Text AppDB MessageId getLocalParentMessageId did shr lmid = do mlm <- lift $ get lmid @@ -328,14 +316,14 @@ deliverHttpBL body mfwd h luInbox = deliverActivityBL' (ObjURI h luInbox) (ObjURI h <$> mfwd) body deliverRemoteDB_ - :: PersistRecordBackend fwder SqlBackend + :: (MonadIO m, PersistRecordBackend fwder SqlBackend) => (ForwardingId -> Key sender -> fwder) -> BL.ByteString -> RemoteActivityId -> Key sender -> ByteString -> [((InstanceId, Host), NonEmpty RemoteRecipient)] - -> AppDB + -> ReaderT SqlBackend m [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId, Key fwder))] deliverRemoteDB_ makeFwder body ractid senderKey sig recips = do let body' = BL.toStrict body @@ -353,32 +341,35 @@ deliverRemoteDB_ makeFwder body ractid senderKey sig recips = do noError ((RemoteRecipient _ _ _ (Just _), _ ), _ ) = Nothing deliverRemoteDB_J - :: BL.ByteString + :: MonadIO m + => BL.ByteString -> RemoteActivityId -> ProjectId -> ByteString -> [((InstanceId, Host), NonEmpty RemoteRecipient)] - -> AppDB + -> ReaderT SqlBackend m [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId, ForwarderProjectId))] deliverRemoteDB_J = deliverRemoteDB_ ForwarderProject deliverRemoteDB_S - :: BL.ByteString + :: MonadIO m + => BL.ByteString -> RemoteActivityId -> SharerId -> ByteString -> [((InstanceId, Host), NonEmpty RemoteRecipient)] - -> AppDB + -> ReaderT SqlBackend m [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId, ForwarderSharerId))] deliverRemoteDB_S = deliverRemoteDB_ ForwarderSharer deliverRemoteDB_R - :: BL.ByteString + :: MonadIO m + => BL.ByteString -> RemoteActivityId -> RepoId -> ByteString -> [((InstanceId, Host), NonEmpty RemoteRecipient)] - -> AppDB + -> ReaderT SqlBackend m [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId, ForwarderRepoId))] deliverRemoteDB_R = deliverRemoteDB_ ForwarderRepo @@ -554,7 +545,20 @@ deliverRemoteDB' , [((InstanceId, Host), NonEmpty (UnfetchedRemoteActorId, LocalURI, UnlinkedDeliveryId))] , [((InstanceId, Host), NonEmpty (UnfetchedRemoteActorId, LocalURI, UnlinkedDeliveryId))] ) -deliverRemoteDB' hContext obid recips known = do +deliverRemoteDB' hContext = deliverRemoteDB'' [hContext] + +deliverRemoteDB'' + :: MonadIO m + => [Host] + -> OutboxItemId + -> [(Host, NonEmpty LocalURI)] + -> [((InstanceId, Host), NonEmpty RemoteRecipient)] + -> ReaderT SqlBackend m + ( [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, DeliveryId))] + , [((InstanceId, Host), NonEmpty (UnfetchedRemoteActorId, LocalURI, UnlinkedDeliveryId))] + , [((InstanceId, Host), NonEmpty (UnfetchedRemoteActorId, LocalURI, UnlinkedDeliveryId))] + ) +deliverRemoteDB'' hContexts obid recips known = do recips' <- for recips $ \ (h, lus) -> do let lus' = NE.nub lus (iid, inew) <- idAndNew <$> insertBy' (Instance h) @@ -584,16 +588,16 @@ deliverRemoteDB' hContext obid recips known = do stillUnknown = mapMaybe (\ (i, (_, _, uk)) -> (i,) <$> uk) recips' allFetched = unionRemotes known moreKnown fetchedDeliv <- for allFetched $ \ (i, rs) -> - let fwd = snd i == hContext + let fwd = snd i `elem` hContexts in (i,) <$> insertMany' (\ (RemoteRecipient raid _ _ msince) -> Delivery raid obid fwd $ isNothing msince) rs unfetchedDeliv <- for unfetched $ \ (i, rs) -> - let fwd = snd i == hContext + let fwd = snd i `elem` hContexts in (i,) <$> insertMany' (\ (uraid, _, msince) -> UnlinkedDelivery uraid obid fwd $ isNothing msince) rs unknownDeliv <- for stillUnknown $ \ (i, lus) -> do -- TODO maybe for URA insertion we should do insertUnique? ros <- insertMany' (\ lu -> RemoteObject (fst i) lu) lus rs <- insertMany' (\ (_lu, roid) -> UnfetchedRemoteActor roid Nothing) ros - let fwd = snd i == hContext + let fwd = snd i `elem` hContexts (i,) <$> insertMany' (\ (_, uraid) -> UnlinkedDelivery uraid obid fwd True) rs return ( takeNoError4 fetchedDeliv @@ -622,10 +626,21 @@ deliverRemoteHttp , [((InstanceId, Host), NonEmpty (UnfetchedRemoteActorId, LocalURI, UnlinkedDeliveryId))] ) -> Worker () -deliverRemoteHttp hContext obid doc (fetched, unfetched, unknown) = do +deliverRemoteHttp hContext = deliverRemoteHttp' [hContext] + +deliverRemoteHttp' + :: [Host] + -> OutboxItemId + -> Doc Activity URIMode + -> ( [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, DeliveryId))] + , [((InstanceId, Host), NonEmpty (UnfetchedRemoteActorId, LocalURI, UnlinkedDeliveryId))] + , [((InstanceId, Host), NonEmpty (UnfetchedRemoteActorId, LocalURI, UnlinkedDeliveryId))] + ) + -> Worker () +deliverRemoteHttp' hContexts obid doc (fetched, unfetched, unknown) = do logDebug' "Starting" let deliver fwd h inbox = do - let fwd' = if h == hContext then Just fwd else Nothing + let fwd' = if h `elem` hContexts then Just fwd else Nothing (isJust fwd',) <$> deliverHttp doc fwd' h inbox now <- liftIO getCurrentTime logDebug' $ @@ -831,7 +846,10 @@ data RemoteRecipient = RemoteRecipient -- * If collections are listed, insert activity to the local members and return -- the remote members insertActivityToLocalInboxes - :: PersistRecordBackend record SqlBackend + :: ( MonadSite m + , YesodHashids (SiteEnv m) + , PersistRecordBackend record SqlBackend + ) => (InboxId -> InboxItemId -> record) -- ^ Database record to insert as an new inbox item to each inbox -> Bool @@ -846,7 +864,7 @@ insertActivityToLocalInboxes -- listed in the recipient set. This is meant to be the activity's -- author. -> LocalRecipientSet - -> AppDB [((InstanceId, Host), NonEmpty RemoteRecipient)] + -> ReaderT SqlBackend m [((InstanceId, Host), NonEmpty RemoteRecipient)] insertActivityToLocalInboxes makeInboxItem requireOwner mauthor mibidAuthor recips = do ibidsSharer <- deleteAuthor <$> getSharerInboxes recips ibidsOther <- concat <$> traverse getOtherInboxes recips @@ -876,7 +894,8 @@ insertActivityToLocalInboxes makeInboxItem requireOwner mauthor mibidAuthor reci Nothing -> id Just ibidAuthor -> L.delete ibidAuthor - getSharerInboxes :: LocalRecipientSet -> AppDB [InboxId] + getSharerInboxes + :: MonadIO m => LocalRecipientSet -> ReaderT SqlBackend m [InboxId] getSharerInboxes sharers = do let shrs = [shr | (shr, s) <- sharers @@ -885,7 +904,9 @@ insertActivityToLocalInboxes makeInboxItem requireOwner mauthor mibidAuthor reci sids <- selectKeysList [SharerIdent <-. shrs] [] map (personInbox . entityVal) <$> selectList [PersonIdent <-. sids] [Asc PersonInbox] - getOtherInboxes :: (ShrIdent, LocalSharerRelatedSet) -> AppDB [InboxId] + getOtherInboxes + :: MonadIO m + => (ShrIdent, LocalSharerRelatedSet) -> ReaderT SqlBackend m [InboxId] getOtherInboxes (shr, LocalSharerRelatedSet _ _ _ projects repos) = do msid <- getKeyBy $ UniqueSharer shr case msid of @@ -910,7 +931,9 @@ insertActivityToLocalInboxes makeInboxItem requireOwner mauthor mibidAuthor reci in map (repoInbox . entityVal) <$> selectList [RepoSharer ==. sid, RepoIdent <-. rps] [] - getSharerFollowerSets :: LocalRecipientSet -> AppDB [FollowerSetId] + getSharerFollowerSets + :: MonadIO m + => LocalRecipientSet -> ReaderT SqlBackend m [FollowerSetId] getSharerFollowerSets sharers = do let shrs = [shr | (shr, s) <- sharers @@ -921,7 +944,10 @@ insertActivityToLocalInboxes makeInboxItem requireOwner mauthor mibidAuthor reci sids <- selectKeysList [SharerIdent <-. shrs] [] map (personFollowers . entityVal) <$> selectList [PersonIdent <-. sids] [] - getOtherFollowerSets :: (ShrIdent, LocalSharerRelatedSet) -> AppDB [FollowerSetId] + getOtherFollowerSets + :: (MonadSite m, YesodHashids (SiteEnv m)) + => (ShrIdent, LocalSharerRelatedSet) + -> ReaderT SqlBackend m [FollowerSetId] getOtherFollowerSets (shr, LocalSharerRelatedSet _ tickets patches projects repos) = do msid <- getKeyBy $ UniqueSharer shr case msid of @@ -1043,7 +1069,8 @@ insertActivityToLocalInboxes makeInboxItem requireOwner mauthor mibidAuthor reci ) return $ lt E.^. LocalTicketFollowers - getLocalFollowers :: [FollowerSetId] -> AppDB [InboxId] + getLocalFollowers + :: MonadIO m => [FollowerSetId] -> ReaderT SqlBackend m [InboxId] getLocalFollowers fsids = do pids <- map (followPerson . entityVal) <$> @@ -1051,7 +1078,11 @@ insertActivityToLocalInboxes makeInboxItem requireOwner mauthor mibidAuthor reci map (personInbox . entityVal) <$> selectList [PersonId <-. pids] [Asc PersonInbox] - getRemoteFollowers :: [FollowerSetId] -> AppDB [((InstanceId, Host), NonEmpty RemoteRecipient)] + getRemoteFollowers + :: MonadIO m + => [FollowerSetId] + -> ReaderT SqlBackend m + [((InstanceId, Host), NonEmpty RemoteRecipient)] getRemoteFollowers fsids = fmap groupRemotes $ E.select $ E.from $ \ (rf `E.InnerJoin` ra `E.InnerJoin` ro `E.InnerJoin` i) -> do @@ -1073,7 +1104,9 @@ insertActivityToLocalInboxes makeInboxItem requireOwner mauthor mibidAuthor reci where toTuples (E.Value iid, E.Value h, E.Value raid, E.Value luA, E.Value luI, E.Value ms) = ((iid, h), RemoteRecipient raid luA luI ms) - getTeams :: (ShrIdent, LocalSharerRelatedSet) -> AppDB [InboxId] + getTeams + :: MonadIO m + => (ShrIdent, LocalSharerRelatedSet) -> ReaderT SqlBackend m [InboxId] getTeams (shr, LocalSharerRelatedSet _ tickets _ projects repos) = do msid <- getKeyBy $ UniqueSharer shr case msid of @@ -1115,22 +1148,24 @@ insertActivityToLocalInboxes makeInboxItem requireOwner mauthor mibidAuthor reci -- * If collections are listed, insert activity to the local members and return -- the remote members deliverLocal' - :: Bool -- ^ Whether to deliver to collection only if owner actor is addressed + :: (MonadSite m, YesodHashids (SiteEnv m)) + => Bool -- ^ Whether to deliver to collection only if owner actor is addressed -> LocalActor -> InboxId -> OutboxItemId -> LocalRecipientSet - -> AppDB [((InstanceId, Host), NonEmpty RemoteRecipient)] + -> ReaderT SqlBackend m [((InstanceId, Host), NonEmpty RemoteRecipient)] deliverLocal' requireOwner author ibidAuthor obiid = insertActivityToLocalInboxes makeItem requireOwner (Just author) (Just ibidAuthor) where makeItem ibid ibiid = InboxItemLocal ibid obiid ibiid insertRemoteActivityToLocalInboxes - :: Bool + :: (MonadSite m, YesodHashids (SiteEnv m)) + => Bool -> RemoteActivityId -> LocalRecipientSet - -> AppDB [((InstanceId, Host), NonEmpty RemoteRecipient)] + -> ReaderT SqlBackend m [((InstanceId, Host), NonEmpty RemoteRecipient)] insertRemoteActivityToLocalInboxes requireOwner ractid = insertActivityToLocalInboxes makeItem requireOwner Nothing Nothing where @@ -1149,3 +1184,11 @@ provideEmptyCollection typ here = do , collectionItems = [] :: [Text] } provideHtmlAndAP coll $ redirectToPrettyJSON here + +insertEmptyOutboxItem obid now = do + h <- asksSite siteInstanceHost + insert OutboxItem + { outboxItemOutbox = obid + , outboxItemActivity = persistJSONObjectFromDoc $ Doc h emptyActivity + , outboxItemPublished = now + } diff --git a/src/Vervis/ActivityPub/Recipient.hs b/src/Vervis/ActivityPub/Recipient.hs index 0ed7f91..846a6b3 100644 --- a/src/Vervis/ActivityPub/Recipient.hs +++ b/src/Vervis/ActivityPub/Recipient.hs @@ -34,6 +34,9 @@ module Vervis.ActivityPub.Recipient , actorRecips , localRecipSieve , localRecipSieve' + + , Aud (..) + , collectAudience ) where @@ -46,11 +49,13 @@ import Data.Foldable import Data.List ((\\)) import Data.List.NonEmpty (NonEmpty, nonEmpty) import Data.Maybe +import Data.Semigroup import Data.Text (Text) import Data.These import Data.Traversable import qualified Data.List.NonEmpty as NE +import qualified Data.List.Ordered as LO import qualified Data.Text as T import Network.FedURI @@ -84,7 +89,7 @@ data LocalActor = LocalActorSharer ShrIdent | LocalActorProject ShrIdent PrjIdent | LocalActorRepo ShrIdent RpIdent - deriving Eq + deriving (Eq, Ord) parseLocalActor :: Route App -> Maybe LocalActor parseLocalActor (SharerR shr) = Just $ LocalActorSharer shr @@ -111,7 +116,7 @@ data LocalPersonCollection | LocalPersonCollectionRepoTeam ShrIdent RpIdent | LocalPersonCollectionRepoFollowers ShrIdent RpIdent | LocalPersonCollectionRepoPatchFollowers ShrIdent RpIdent (KeyHashid LocalTicket) - deriving Eq + deriving (Eq, Ord) parseLocalPersonCollection :: Route App -> Maybe LocalPersonCollection @@ -592,3 +597,38 @@ localRecipSieve' sieve allowSharers allowOthers = where applyRepo (LocalRepoDirectSet r' t' f') (LocalRepoDirectSet r t f) = LocalRepoDirectSet (r && (r' || allowOthers)) (t && t') (f && f') + +data Aud u + = AudLocal [LocalActor] [LocalPersonCollection] + | AudRemote (Authority u) [LocalURI] [LocalURI] + +collectAudience + :: Foldable f + => f (Aud u) + -> ( LocalRecipientSet + , [(Authority u, NonEmpty LocalURI)] + , [Authority u] + , [Route App] + , [ObjURI u] + ) +collectAudience auds = + let (locals, remotes) = partitionAudience auds + (actors, collections) = + let organize = LO.nubSort . concat + in bimap organize organize $ unzip locals + groupedRemotes = + let organize = LO.nubSort . sconcat + in map (second $ bimap organize organize . NE.unzip) $ + groupAllExtract fst snd remotes + in ( makeRecipientSet actors collections + , mapMaybe (\ (h, (as, _)) -> (h,) <$> nonEmpty as) groupedRemotes + , [ h | (h, (_, cs)) <- groupedRemotes, not (null cs) ] + , map renderLocalActor actors ++ + map renderLocalPersonCollection collections + , concatMap (\ (h, (as, cs)) -> ObjURI h <$> as ++ cs) groupedRemotes + ) + where + partitionAudience = foldl' f ([], []) + where + f (ls, rs) (AudLocal as cs) = ((as, cs) : ls, rs) + f (ls, rs) (AudRemote h as cs) = (ls , (h, (as, cs)) : rs) diff --git a/src/Vervis/Client.hs b/src/Vervis/Client.hs index 74883c4..8d3b64a 100644 --- a/src/Vervis/Client.hs +++ b/src/Vervis/Client.hs @@ -210,7 +210,7 @@ followRepo shrAuthor shrObject rpObject hide = do offerTicket :: (MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App) - => ShrIdent -> TextHtml -> TextPandocMarkdown -> ShrIdent -> PrjIdent -> m (Either Text (TextHtml, Audience URIMode, Offer URIMode)) + => ShrIdent -> TextHtml -> TextPandocMarkdown -> ShrIdent -> PrjIdent -> m (Either Text (TextHtml, Audience URIMode, AP.Ticket URIMode, FedURI)) offerTicket shrAuthor (TextHtml title) (TextPandocMarkdown desc) shr prj = runExceptT $ do encodeRouteLocal <- getEncodeRouteLocal encodeRouteHome <- getEncodeRouteHome @@ -243,10 +243,7 @@ offerTicket shrAuthor (TextHtml title) (TextPandocMarkdown desc) shr prj = runEx , AP.ticketIsResolved = False , AP.ticketAttachment = Nothing } - offer = Offer - { offerObject = ticket - , offerTarget = encodeRouteHome $ ProjectR shr prj - } + target = encodeRouteHome $ ProjectR shr prj audience = Audience { audienceTo = map encodeRouteHome $ recipsA ++ recipsC , audienceBto = [] @@ -255,7 +252,7 @@ offerTicket shrAuthor (TextHtml title) (TextPandocMarkdown desc) shr prj = runEx , audienceGeneral = [] , audienceNonActors = map encodeRouteHome recipsC } - return (summary, audience, offer) + return (summary, audience, ticket, target) createTicket :: (MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App) @@ -330,7 +327,7 @@ undoFollow undoFollow shrAuthor pidAuthor getFsid typ objRoute recipRoute = runExceptT $ do encodeRouteLocal <- getEncodeRouteLocal encodeRouteHome <- getEncodeRouteHome - obiidFollow <- runDBExcept $ do + obiidFollow <- runSiteDBExcept $ do fsid <- getFsid mf <- lift $ getValBy $ UniqueFollow pidAuthor fsid followFollow <$> fromMaybeE mf ("Not following this " <> typ) diff --git a/src/Vervis/Federation.hs b/src/Vervis/Federation.hs index 3741dba..94035fc 100644 --- a/src/Vervis/Federation.hs +++ b/src/Vervis/Federation.hs @@ -125,12 +125,12 @@ parseTicket project luContext = do _ -> throwE "Local context isn't a ticket route" handleSharerInbox - :: UTCTime - -> ShrIdent + :: ShrIdent + -> UTCTime -> ActivityAuthentication -> ActivityBody - -> ExceptT Text Handler Text -handleSharerInbox _now shrRecip (ActivityAuthLocal (ActivityAuthLocalPerson pidAuthor)) body = do + -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text)) +handleSharerInbox shrRecip _now (ActivityAuthLocal (ActivityAuthLocalPerson pidAuthor)) body = (,Nothing) <$> do (shrActivity, obiid) <- do luAct <- fromMaybeE @@ -174,7 +174,7 @@ handleSharerInbox _now shrRecip (ActivityAuthLocal (ActivityAuthLocalPerson pidA "Activity already exists in inbox of /s/" <> recip Just _ -> return $ "Activity inserted to inbox of /s/" <> recip -handleSharerInbox _now shrRecip (ActivityAuthLocal (ActivityAuthLocalProject jidAuthor)) body = do +handleSharerInbox shrRecip _now (ActivityAuthLocal (ActivityAuthLocalProject jidAuthor)) body = (,Nothing) <$> do (shrActivity, prjActivity, obiid) <- do luAct <- fromMaybeE @@ -218,7 +218,7 @@ handleSharerInbox _now shrRecip (ActivityAuthLocal (ActivityAuthLocalProject jid "Activity already exists in inbox of /s/" <> recip Just _ -> return $ "Activity inserted to inbox of /s/" <> recip -handleSharerInbox _now shrRecip (ActivityAuthLocal (ActivityAuthLocalRepo ridAuthor)) body = do +handleSharerInbox shrRecip _now (ActivityAuthLocal (ActivityAuthLocalRepo ridAuthor)) body = (,Nothing) <$> do (shrActivity, rpActivity, obiid) <- do luAct <- fromMaybeE @@ -262,37 +262,42 @@ handleSharerInbox _now shrRecip (ActivityAuthLocal (ActivityAuthLocalRepo ridAut "Activity already exists in inbox of /s/" <> recip Just _ -> return $ "Activity inserted to inbox of /s/" <> recip -handleSharerInbox now shrRecip (ActivityAuthRemote author) body = +handleSharerInbox shrRecip now (ActivityAuthRemote author) body = case activitySpecific $ actbActivity body of AcceptActivity accept -> - sharerAcceptF shrRecip now author body accept + (,Nothing) <$> sharerAcceptF shrRecip now author body accept CreateActivity (Create obj mtarget) -> case obj of CreateNote note -> - sharerCreateNoteF now shrRecip author body note + (,Nothing) <$> sharerCreateNoteF now shrRecip author body note CreateTicket ticket -> - sharerCreateTicketF now shrRecip author body ticket mtarget - _ -> return "Unsupported create object type for sharers" + (,Nothing) <$> sharerCreateTicketF now shrRecip author body ticket mtarget + _ -> return ("Unsupported create object type for sharers", Nothing) FollowActivity follow -> - sharerFollowF shrRecip now author body follow - OfferActivity offer -> - sharerOfferTicketF now shrRecip author body offer + (,Nothing) <$> sharerFollowF shrRecip now author body follow + OfferActivity (Offer obj target) -> + case obj of + OfferTicket ticket -> + (,Nothing) <$> sharerOfferTicketF now shrRecip author body ticket target + OfferDep dep -> + sharerOfferDepF now shrRecip author body dep target + _ -> return ("Unsupported offer object type for sharers", Nothing) PushActivity push -> - sharerPushF shrRecip now author body push + (,Nothing) <$> sharerPushF shrRecip now author body push RejectActivity reject -> - sharerRejectF shrRecip now author body reject + (,Nothing) <$> sharerRejectF shrRecip now author body reject UndoActivity undo -> - sharerUndoF shrRecip now author body undo - _ -> return "Unsupported activity type for sharers" + (,Nothing) <$> sharerUndoF shrRecip now author body undo + _ -> return ("Unsupported activity type for sharers", Nothing) handleProjectInbox - :: UTCTime - -> ShrIdent + :: ShrIdent -> PrjIdent + -> UTCTime -> ActivityAuthentication -> ActivityBody - -> ExceptT Text Handler Text -handleProjectInbox now shrRecip prjRecip auth body = do + -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text)) +handleProjectInbox shrRecip prjRecip now auth body = (,Nothing) <$> do remoteAuthor <- case auth of ActivityAuthLocal local -> throwE $ errorLocalForwarded local @@ -307,8 +312,11 @@ handleProjectInbox now shrRecip prjRecip auth body = do _ -> error "Unsupported create object type for projects" FollowActivity follow -> projectFollowF shrRecip prjRecip now remoteAuthor body follow - OfferActivity offer -> - projectOfferTicketF now shrRecip prjRecip remoteAuthor body offer + OfferActivity (Offer obj target) -> + case obj of + OfferTicket ticket -> + projectOfferTicketF now shrRecip prjRecip remoteAuthor body ticket target + _ -> return "Unsupported offer object type for projects" UndoActivity undo -> projectUndoF shrRecip prjRecip now remoteAuthor body undo _ -> return "Unsupported activity type for projects" @@ -324,13 +332,13 @@ handleProjectInbox now shrRecip prjRecip auth body = do T.pack (show $ fromSqlKey rid) handleRepoInbox - :: UTCTime - -> ShrIdent + :: ShrIdent -> RpIdent + -> UTCTime -> ActivityAuthentication -> ActivityBody - -> ExceptT Text Handler Text -handleRepoInbox now shrRecip rpRecip auth body = do + -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text)) +handleRepoInbox shrRecip rpRecip now auth body = (,Nothing) <$> do remoteAuthor <- case auth of ActivityAuthLocal local -> throwE $ errorLocalForwarded local diff --git a/src/Vervis/Federation/Discussion.hs b/src/Vervis/Federation/Discussion.hs index 81b1872..ea15177 100644 --- a/src/Vervis/Federation/Discussion.hs +++ b/src/Vervis/Federation/Discussion.hs @@ -68,6 +68,7 @@ import Vervis.ActivityPub import Vervis.ActivityPub.Recipient import Vervis.FedURI import Vervis.Federation.Auth +import Vervis.Federation.Util import Vervis.Foundation import Vervis.Model import Vervis.Model.Ident @@ -100,32 +101,6 @@ checkNote (Note mluNote _ _ muParent muCtx mpub source content) = do else Just <$> parseParent uParent return (luNote, published, context, mparent, source, content) --- | Insert a remote activity delivered to us into our inbox. Return its --- database ID if the activity wasn't already in our inbox. -insertToInbox - :: UTCTime - -> RemoteAuthor - -> ActivityBody - -> InboxId - -> LocalURI - -> Bool - -> AppDB (Maybe RemoteActivityId) -insertToInbox now author body ibid luCreate unread = do - let iidAuthor = remoteAuthorInstance author - roid <- - either entityKey id <$> insertBy' (RemoteObject iidAuthor luCreate) - ractid <- either entityKey id <$> insertBy' RemoteActivity - { remoteActivityIdent = roid - , remoteActivityContent = persistJSONFromBL $ actbBL body - , remoteActivityReceived = now - } - ibiid <- insert $ InboxItem unread - new <- isRight <$> insertBy' (InboxItemRemote ibid ractid ibiid) - return $ - if new - then Just ractid - else Nothing - -- | Given the parent specified by the Note we received, check if we already -- know and have this parent note in the DB, and whether the child and parent -- belong to the same discussion root. diff --git a/src/Vervis/Federation/Ticket.hs b/src/Vervis/Federation/Ticket.hs index 79d0a7a..9bf5db0 100644 --- a/src/Vervis/Federation/Ticket.hs +++ b/src/Vervis/Federation/Ticket.hs @@ -19,6 +19,8 @@ module Vervis.Federation.Ticket , sharerCreateTicketF , projectCreateTicketF + + , sharerOfferDepF ) where @@ -30,6 +32,7 @@ import Control.Monad.Trans.Except import Control.Monad.Trans.Maybe import Data.Aeson import Data.Bifunctor +import Data.Bitraversable import Data.Foldable import Data.Function import Data.List (nub, union) @@ -70,10 +73,13 @@ import Vervis.ActivityPub import Vervis.ActivityPub.Recipient import Vervis.FedURI import Vervis.Federation.Auth +import Vervis.Federation.Util import Vervis.Foundation import Vervis.Model import Vervis.Model.Ident import Vervis.Model.Ticket +import Vervis.Patch +import Vervis.Ticket checkOffer :: AP.Ticket URIMode @@ -95,9 +101,10 @@ sharerOfferTicketF -> ShrIdent -> RemoteAuthor -> ActivityBody - -> Offer URIMode + -> AP.Ticket URIMode + -> FedURI -> ExceptT Text Handler Text -sharerOfferTicketF now shrRecip author body (Offer ticket uTarget) = do +sharerOfferTicketF now shrRecip author body ticket uTarget = do (hProject, shrProject, prjProject) <- parseTarget uTarget luOffer <- fromMaybeE (activityId $ actbActivity body) "Offer without 'id'" {-deps <- -} @@ -192,10 +199,11 @@ projectOfferTicketF -> PrjIdent -> RemoteAuthor -> ActivityBody - -> Offer URIMode + -> AP.Ticket URIMode + -> FedURI -> ExceptT Text Handler Text projectOfferTicketF - now shrRecip prjRecip author body (Offer ticket uTarget) = do + now shrRecip prjRecip author body ticket uTarget = do targetIsUs <- lift $ runExceptT checkTarget case targetIsUs of Left t -> do @@ -737,3 +745,447 @@ projectCreateTicketF now shrRecip prjRecip author body ticket muTarget = do delete tid return $ Left True Just _rtid -> return $ Right () + +sharerOfferDepF + :: UTCTime + -> ShrIdent + -> RemoteAuthor + -> ActivityBody + -> AP.TicketDependency URIMode + -> FedURI + -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text)) +sharerOfferDepF now shrRecip author body dep uTarget = do + luOffer <- fromMaybeE (activityId $ actbActivity body) "Offer without 'id'" + (parent, child) <- checkDepAndTarget dep uTarget + (localRecips, _remoteRecips) <- do + mrecips <- parseAudience $ activityAudience $ actbActivity body + fromMaybeE mrecips "Offer Dep with no recipients" + msig <- checkForward $ LocalActorSharer shrRecip + personRecip <- lift $ runDB $ do + sid <- getKeyBy404 $ UniqueSharer shrRecip + getValBy404 $ UniquePersonIdent sid + return $ (,) "Ran initial checks, doing the rest asynchronously" $ Just $ do + manager <- asksSite appHttpManager + relevantParent <- + for (parentRelevance shrRecip parent) $ \ (talid, patch) -> do + (parentLtid, parentCtx) <- runSiteDBExcept $ do + let getTcr tcr = do + let getRoid roid = do + ro <- getJust roid + i <- getJust $ remoteObjectInstance ro + return $ mkuri (i, ro) + roidT <- remoteActorIdent <$> getJust (ticketProjectRemoteTracker tcr) + let mroidJ = ticketProjectRemoteProject tcr + (,) <$> getRoid roidT <*> traverse getRoid mroidJ + if patch + then do + (_, Entity ltid _, _, context, _) <- do + mticket <- lift $ getSharerPatch shrRecip talid + fromMaybeE mticket $ "Parent" <> ": No such sharer-patch" + context' <- + lift $ + bitraverse + (\ (_, Entity _ trl) -> do + r <- getJust $ ticketRepoLocalRepo trl + s <- getJust $ repoSharer r + return $ Right (sharerIdent s, repoIdent r) + ) + (\ (Entity _ tcr, _) -> getTcr tcr) + context + return (ltid, context') + else do + (_, Entity ltid _, _, context) <- do + mticket <- lift $ getSharerTicket shrRecip talid + fromMaybeE mticket $ "Parent" <> ": No such sharer-ticket" + context' <- + lift $ + bitraverse + (\ (_, Entity _ tpl) -> do + j <- getJust $ ticketProjectLocalProject tpl + s <- getJust $ projectSharer j + return $ Left (sharerIdent s, projectIdent j) + ) + (\ (Entity _ tcr, _) -> getTcr tcr) + context + return (ltid, context') + parentCtx' <- bifor parentCtx pure $ \ (uTracker, muProject) -> do + let uProject = fromMaybe uTracker muProject + obj <- withExceptT T.pack $ AP.fetchAP manager $ Left uProject + unless (objId obj == uProject) $ + throwE "Project 'id' differs from the URI we fetched" + return + (uTracker, objUriAuthority uProject, objFollowers obj, objTeam obj) + (childId, childCtx, childAuthor) <- + case child of + Left wi -> runSiteDBExcept $ do + (ltid, ctx, author) <- getWorkItem "Child" wi + return (Left (wi, ltid), second mkuri ctx, second mkuri author) + Right u -> do + Doc hAuthor t <- withExceptT T.pack $ AP.fetchAP manager $ Left u + (hTicket, tl) <- fromMaybeE (AP.ticketLocal t) "Child ticket no 'id'" + unless (ObjURI hAuthor (AP.ticketId tl) == u) $ + throwE "Ticket 'id' differs from the URI we fetched" + uCtx <- fromMaybeE (AP.ticketContext t) "Ticket without 'context'" + ctx <- parseTicketContext uCtx + author <- parseTicketAuthor $ ObjURI hTicket (AP.ticketAttributedTo t) + return (Right (u, AP.ticketParticipants tl), ctx, author) + childCtx' <- bifor childCtx pure $ \ u -> do + obj <- withExceptT T.pack $ AP.fetchAP manager $ Left u + unless (objId obj == u) $ + throwE "Project 'id' differs from the URI we fetched" + u' <- + case (objContext obj, objInbox obj) of + (Just c, Nothing) -> do + hl <- hostIsLocal $ objUriAuthority c + when hl $ throwE "Child remote context has a local context" + pure c + (Nothing, Just _) -> pure u + _ -> throwE "Umm context-inbox thing" + return + (u', objUriAuthority u, objFollowers obj, objTeam obj) + return (talid, patch, parentLtid, parentCtx', childId, childCtx', childAuthor) + mhttp <- lift $ runSiteDB $ do + mractid <- insertToInbox now author body (personInbox personRecip) luOffer True + for mractid $ \ ractid -> do + mremotesHttpFwd <- for msig $ \ sig -> do + relevantFollowers <- askRelevantFollowers + let sieve = + makeRecipientSet [] $ catMaybes + [ relevantFollowers shrRecip parent + , relevantFollowers shrRecip child + ] + remoteRecips <- + insertRemoteActivityToLocalInboxes + False ractid $ + localRecipSieve' + sieve False False localRecips + (sig,) <$> deliverRemoteDB_S (actbBL body) ractid (personIdent personRecip) sig remoteRecips + mremotesHttpAccept <- for relevantParent $ \ ticketData@(_, _, parentLtid, _, childId, _, _) -> do + obiidAccept <- insertEmptyOutboxItem (personOutbox personRecip) now + tdid <- insertDep ractid parentLtid childId obiidAccept + (docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <- + insertAccept luOffer obiidAccept tdid ticketData + knownRemoteRecipsAccept <- + deliverLocal' + False + (LocalActorSharer shrRecip) + (personInbox personRecip) + obiidAccept + localRecipsAccept + (obiidAccept,docAccept,fwdHostsAccept,) <$> deliverRemoteDB'' fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept + return (mremotesHttpFwd, mremotesHttpAccept) + case mhttp of + Nothing -> return "I already have this activity in my inbox, doing nothing" + Just (mremotesHttpFwd, mremotesHttpAccept) -> do + for_ mremotesHttpFwd $ \ (sig, remotes) -> + forkWorker "sharerOfferDepF inbox-forwarding" $ + deliverRemoteHTTP_S now shrRecip (actbBL body) sig remotes + for_ mremotesHttpAccept $ \ (obiid, doc, fwdHosts, remotes) -> + forkWorker "sharerOfferDepF Accept HTTP delivery" $ + deliverRemoteHttp' fwdHosts obiid doc remotes + return $ + case (mremotesHttpAccept, mremotesHttpFwd) of + (Nothing, Nothing) -> "Parent not mine, just stored in inbox and no inbox-forwarding to do" + (Nothing, Just _) -> "Parent not mine, just stored in inbox and ran inbox-forwarding" + (Just _, Nothing) -> "Accepted new ticket dep, no inbox-forwarding to do" + (Just _, Just _) -> "Accepted new ticket dep and ran inbox-forwarding of the Offer" + where + checkDepAndTarget + (AP.TicketDependency id_ uParent uChild _attrib published updated) uTarget = do + verifyNothingE id_ "Dep with 'id'" + parent <- parseWorkItem "Dep parent" uParent + child <- parseWorkItem "Dep child" uChild + when (parent == child) $ + throwE "Parent and child are the same work item" + verifyNothingE published "Dep with 'published'" + verifyNothingE updated "Dep with 'updated'" + target <- parseTarget uTarget + checkParentAndTarget parent target + return (parent, child) + where + parseWorkItem name u@(ObjURI h lu) = do + hl <- hostIsLocal h + if hl + then Left <$> do + route <- + fromMaybeE (decodeRouteLocal lu) $ + name <> ": Not a valid route" + case route of + SharerTicketR shr talkhid -> do + talid <- decodeKeyHashidE talkhid $ name <> ": Invalid talkhid" + return $ WorkItemSharerTicket shr talid False + SharerPatchR shr talkhid -> do + talid <- decodeKeyHashidE talkhid $ name <> ": Invalid talkhid" + return $ WorkItemSharerTicket shr talid True + ProjectTicketR shr prj ltkhid -> do + ltid <- decodeKeyHashidE ltkhid $ name <> ": Invalid ltkhid" + return $ WorkItemProjectTicket shr prj ltid + RepoPatchR shr rp ltkhid -> do + ltid <- decodeKeyHashidE ltkhid $ name <> ": Invalid ltkhid" + return $ WorkItemRepoPatch shr rp ltid + _ -> throwE $ name <> ": not a work item route" + else return $ Right u + parseTarget u@(ObjURI h lu) = do + hl <- hostIsLocal h + if hl + then Left <$> do + route <- + fromMaybeE + (decodeRouteLocal lu) + "Offer local target isn't a valid route" + fromMaybeE + (parseLocalActor route) + "Offer local target isn't an actor route" + else return $ Right u + checkParentAndTarget (Left wi) (Left la) = + unless (workItemActor wi == la) $ + throwE "Parent and target mismatch" + where + workItemActor (WorkItemSharerTicket shr _ _) = LocalActorSharer shr + workItemActor (WorkItemProjectTicket shr prj _) = LocalActorProject shr prj + workItemActor (WorkItemRepoPatch shr rp _) = LocalActorRepo shr rp + checkParentAndTarget (Left _) (Right _) = throwE "Local parent but remote target" + checkParentAndTarget (Right _) (Left _) = throwE "Local target but remote parent" + checkParentAndTarget (Right _) (Right _) = return () + parentRelevance shr (Left (WorkItemSharerTicket shr' talid patch)) + | shr == shr' = Just (talid, patch) + parentRelevance _ _ = Nothing + {- + getWorkItem + :: MonadIO m + => Text + -> WorkItem + -> ExceptT Text (ReaderT SqlBaclend m) + ( LocalTicketId + , Either + (Either (ShrIdent, PrjIdent) (ShrIdent, RpIdent)) + (Instance, RemoteObject) + , Either ShrIdent (Instance, RemoteObject) + ) + -} + getWorkItem name (WorkItemSharerTicket shr talid False) = do + (_, Entity ltid _, _, context) <- do + mticket <- lift $ getSharerTicket shr talid + fromMaybeE mticket $ name <> ": No such sharer-ticket" + context' <- + lift $ + bitraverse + (\ (_, Entity _ tpl) -> do + j <- getJust $ ticketProjectLocalProject tpl + s <- getJust $ projectSharer j + return $ Left (sharerIdent s, projectIdent j) + ) + (\ (Entity _ tcr, _) -> do + roid <- + case ticketProjectRemoteProject tcr of + Nothing -> + remoteActorIdent <$> + getJust (ticketProjectRemoteTracker tcr) + Just roid -> return roid + ro <- getJust roid + i <- getJust $ remoteObjectInstance ro + return (i, ro) + ) + context + return (ltid, context', Left shr) + getWorkItem name (WorkItemSharerTicket shr talid True) = do + (_, Entity ltid _, _, context, _) <- do + mticket <- lift $ getSharerPatch shr talid + fromMaybeE mticket $ name <> ": No such sharer-patch" + context' <- + lift $ + bitraverse + (\ (_, Entity _ trl) -> do + r <- getJust $ ticketRepoLocalRepo trl + s <- getJust $ repoSharer r + return $ Right (sharerIdent s, repoIdent r) + ) + (\ (Entity _ tcr, _) -> do + roid <- + case ticketProjectRemoteProject tcr of + Nothing -> + remoteActorIdent <$> + getJust (ticketProjectRemoteTracker tcr) + Just roid -> return roid + ro <- getJust roid + i <- getJust $ remoteObjectInstance ro + return (i, ro) + ) + context + return (ltid, context', Left shr) + getWorkItem name (WorkItemProjectTicket shr prj ltid) = do + mticket <- lift $ getProjectTicket shr prj ltid + (Entity _ s, Entity _ j, _, _, _, _, author) <- + fromMaybeE mticket $ name <> ": No such project-ticket" + author' <- + lift $ + bitraverse + (\ (Entity _ tal, _) -> do + p <- getJust $ ticketAuthorLocalAuthor tal + sharerIdent <$> getJust (personIdent p) + ) + (\ (Entity _ tar) -> do + ra <- getJust $ ticketAuthorRemoteAuthor tar + ro <- getJust $ remoteActorIdent ra + i <- getJust $ remoteObjectInstance ro + return (i, ro) + ) + author + return (ltid, Left $ Left (sharerIdent s, projectIdent j), author') + getWorkItem name (WorkItemRepoPatch shr rp ltid) = do + mticket <- lift $ getRepoPatch shr rp ltid + (Entity _ s, Entity _ r, _, _, _, _, author, _) <- + fromMaybeE mticket $ name <> ": No such repo-patch" + author' <- + lift $ + bitraverse + (\ (Entity _ tal, _) -> do + p <- getJust $ ticketAuthorLocalAuthor tal + sharerIdent <$> getJust (personIdent p) + ) + (\ (Entity _ tar) -> do + ra <- getJust $ ticketAuthorRemoteAuthor tar + ro <- getJust $ remoteActorIdent ra + i <- getJust $ remoteObjectInstance ro + return (i, ro) + ) + author + return (ltid, Left $ Right (sharerIdent s, repoIdent r), author') + mkuri (i, ro) = ObjURI (instanceHost i) (remoteObjectIdent ro) + parseTicketContext u@(ObjURI h lu) = do + hl <- hostIsLocal h + if hl + then Left <$> do + route <- fromMaybeE (decodeRouteLocal lu) "Not a route" + case route of + ProjectR shr prj -> return $ Left (shr, prj) + RepoR shr rp -> return $ Right (shr, rp) + _ -> throwE "Not a ticket context route" + else return $ Right u + parseTicketAuthor u@(ObjURI h lu) = do + hl <- hostIsLocal h + if hl + then Left <$> do + route <- fromMaybeE (decodeRouteLocal lu) "Not a route" + case route of + SharerR shr -> return shr + _ -> throwE "Not a ticket author route" + else return $ Right u + askRelevantFollowers = do + hashTALID <- getEncodeKeyHashid + return $ \ shr wi -> followers hashTALID <$> parentRelevance shr wi + where + followers hashTALID (talid, patch) = + let coll = + if patch + then LocalPersonCollectionSharerPatchFollowers + else LocalPersonCollectionSharerTicketFollowers + in coll shrRecip (hashTALID talid) + insertDep ractidOffer ltidParent child obiidAccept = do + tdid <- insert LocalTicketDependency + { localTicketDependencyParent = ltidParent + , localTicketDependencyCreated = now + , localTicketDependencyAccept = obiidAccept + } + case child of + Left (_wi, ltid) -> insert_ TicketDependencyChildLocal + { ticketDependencyChildLocalDep = tdid + , ticketDependencyChildLocalChild = ltid + } + Right (ObjURI h lu, _luFollowers) -> do + iid <- either entityKey id <$> insertBy' (Instance h) + roid <- either entityKey id <$> insertBy' (RemoteObject iid lu) + insert_ TicketDependencyChildRemote + { ticketDependencyChildRemoteDep = tdid + , ticketDependencyChildRemoteChild = roid + } + insert_ TicketDependencyAuthorRemote + { ticketDependencyAuthorRemoteDep = tdid + , ticketDependencyAuthorRemoteAuthor = remoteAuthorId author + , ticketDependencyAuthorRemoteOpen = ractidOffer + } + return tdid + insertAccept luOffer obiidAccept tdid (talid, patch, _, parentCtx, childId, childCtx, childAuthor) = do + encodeRouteLocal <- getEncodeRouteLocal + encodeRouteHome <- getEncodeRouteHome + followers <- askFollowers + workItemFollowers <- askWorkItemFollowers + hLocal <- asksSite siteInstanceHost + obikhidAccept <- encodeKeyHashid obiidAccept + tdkhid <- encodeKeyHashid tdid + ra <- getJust $ remoteAuthorId author + let ObjURI hAuthor luAuthor = remoteAuthorURI author + + audAuthor = + AudRemote hAuthor [luAuthor] (maybeToList $ remoteActorFollowers ra) + audParentContext = contextAudience parentCtx + audChildContext = contextAudience childCtx + audParent = AudLocal [LocalActorSharer shrRecip] [followers talid patch] + audChildAuthor = + case childAuthor of + Left shr -> AudLocal [LocalActorSharer shr] [] + Right (ObjURI h lu) -> AudRemote h [lu] [] + audChildFollowers = + case childId of + Left (wi, _ltid) -> AudLocal [] [workItemFollowers wi] + Right (ObjURI h _, luFollowers) -> AudRemote h [] [luFollowers] + + (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = + collectAudience $ + audAuthor : + audParent : + audChildAuthor : + audChildFollowers : + audParentContext ++ audChildContext + + recips = map encodeRouteHome audLocal ++ audRemote + doc = Doc hLocal Activity + { activityId = + Just $ encodeRouteLocal $ + SharerOutboxItemR shrRecip obikhidAccept + , activityActor = encodeRouteLocal $ SharerR shrRecip + , activitySummary = Nothing + , activityAudience = Audience recips [] [] [] [] [] + , activitySpecific = AcceptActivity Accept + { acceptObject = ObjURI hAuthor luOffer + , acceptResult = + Just $ encodeRouteLocal $ TicketDepR tdkhid + } + } + update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc] + return (doc, recipientSet, remoteActors, fwdHosts) + where + contextAudience ctx = + case ctx of + Left (Left (shr, prj)) -> + pure $ AudLocal + [LocalActorProject shr prj] + [ LocalPersonCollectionProjectTeam shr prj + , LocalPersonCollectionProjectFollowers shr prj + ] + Left (Right (shr, rp)) -> + pure $ AudLocal + [LocalActorRepo shr rp] + [ LocalPersonCollectionRepoTeam shr rp + , LocalPersonCollectionRepoFollowers shr rp + ] + Right (ObjURI hTracker luTracker, hProject, luFollowers, luTeam) -> + [ AudRemote hTracker [luTracker] [] + , AudRemote hProject [] (catMaybes [luFollowers, luTeam]) + ] + askFollowers = do + hashTALID <- getEncodeKeyHashid + return $ \ talid patch -> + let coll = + if patch + then LocalPersonCollectionSharerPatchFollowers + else LocalPersonCollectionSharerTicketFollowers + in coll shrRecip (hashTALID talid) + askWorkItemFollowers = do + hashTALID <- getEncodeKeyHashid + hashLTID <- getEncodeKeyHashid + let workItemFollowers (WorkItemSharerTicket shr talid False) = LocalPersonCollectionSharerTicketFollowers shr $ hashTALID talid + workItemFollowers (WorkItemSharerTicket shr talid True) = LocalPersonCollectionSharerPatchFollowers shr $ hashTALID talid + workItemFollowers (WorkItemProjectTicket shr prj ltid) = LocalPersonCollectionProjectTicketFollowers shr prj $ hashLTID ltid + workItemFollowers (WorkItemRepoPatch shr rp ltid) = LocalPersonCollectionRepoPatchFollowers shr rp $ hashLTID ltid + return workItemFollowers diff --git a/src/Vervis/Federation/Util.hs b/src/Vervis/Federation/Util.hs new file mode 100644 index 0000000..fa999ac --- /dev/null +++ b/src/Vervis/Federation/Util.hs @@ -0,0 +1,62 @@ +{- This file is part of Vervis. + - + - Written in 2019, 2020 by fr33domlover . + - + - ♡ Copying is an act of love. Please copy, reuse and share. + - + - The author(s) have dedicated all copyright and related and neighboring + - rights to this software to the public domain worldwide. This software is + - distributed without any warranty. + - + - You should have received a copy of the CC0 Public Domain Dedication along + - with this software. If not, see + - . + -} + +module Vervis.Federation.Util + ( insertToInbox + ) +where + +import Control.Monad.IO.Class +import Control.Monad.Trans.Reader +import Data.Either +import Data.Time.Clock +import Database.Persist +import Database.Persist.Sql + +import Database.Persist.JSON +import Network.FedURI + +import Database.Persist.Local + +import Vervis.Federation.Auth +import Vervis.Foundation +import Vervis.Model + +-- | Insert a remote activity delivered to us into our inbox. Return its +-- database ID if the activity wasn't already in our inbox. +insertToInbox + :: MonadIO m + => UTCTime + -> RemoteAuthor + -> ActivityBody + -> InboxId + -> LocalURI + -> Bool + -> ReaderT SqlBackend m (Maybe RemoteActivityId) +insertToInbox now author body ibid luAct unread = do + let iidAuthor = remoteAuthorInstance author + roid <- + either entityKey id <$> insertBy' (RemoteObject iidAuthor luAct) + ractid <- either entityKey id <$> insertBy' RemoteActivity + { remoteActivityIdent = roid + , remoteActivityContent = persistJSONFromBL $ actbBL body + , remoteActivityReceived = now + } + ibiid <- insert $ InboxItem unread + new <- isRight <$> insertBy' (InboxItemRemote ibid ractid ibiid) + return $ + if new + then Just ractid + else Nothing diff --git a/src/Vervis/Field/Ticket.hs b/src/Vervis/Field/Ticket.hs index 17f2d1b..61316fd 100644 --- a/src/Vervis/Field/Ticket.hs +++ b/src/Vervis/Field/Ticket.hs @@ -15,7 +15,7 @@ module Vervis.Field.Ticket ( selectAssigneeFromProject - , selectTicketDep + --, selectTicketDep ) where @@ -33,7 +33,7 @@ import qualified Database.Persist as P import Database.Persist.Sql.Graph.Connects (uconnects) import Vervis.Foundation (Handler) -import Vervis.GraphProxy (ticketDepGraph) +--import Vervis.GraphProxy (ticketDepGraph) import Vervis.Model import Vervis.Model.Ident (shr2text) @@ -52,6 +52,7 @@ selectAssigneeFromProject pid jid = selectField $ do return (sharer ^. SharerIdent, person ^. PersonId) optionsPairs $ map (shr2text . unValue *** unValue) l +{- checkNotSelf :: TicketId -> Field Handler TicketId -> Field Handler TicketId checkNotSelf tidP = checkBool (/= tidP) ("A ticket can’t depend on itself" :: Text) @@ -80,3 +81,4 @@ selectTicketDep jid tid = orderBy [asc $ t ^. TicketId] return (t ^. TicketTitle, t ^. TicketId) optionsPairs $ map (bimap unValue unValue) ts +-} diff --git a/src/Vervis/Form/Ticket.hs b/src/Vervis/Form/Ticket.hs index f10886b..f0666ea 100644 --- a/src/Vervis/Form/Ticket.hs +++ b/src/Vervis/Form/Ticket.hs @@ -20,7 +20,7 @@ module Vervis.Form.Ticket , assignTicketForm , claimRequestForm , ticketFilterForm - , ticketDepForm + --, ticketDepForm ) where @@ -273,8 +273,10 @@ ticketFilterAForm = mk ticketFilterForm :: Form TicketFilter ticketFilterForm = renderDivs ticketFilterAForm +{- ticketDepAForm :: ProjectId -> TicketId -> AForm Handler TicketId ticketDepAForm jid tid = areq (selectTicketDep jid tid) "Dependency" Nothing ticketDepForm :: ProjectId -> TicketId -> Form TicketId ticketDepForm jid tid = renderDivs $ ticketDepAForm jid tid +-} diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index f69b810..73de860 100644 --- a/src/Vervis/Foundation.hs +++ b/src/Vervis/Foundation.hs @@ -130,7 +130,7 @@ type MessageKeyHashid = KeyHashid Message type LocalMessageKeyHashid = KeyHashid LocalMessage type LocalTicketKeyHashid = KeyHashid LocalTicket type TicketAuthorLocalKeyHashid = KeyHashid TicketAuthorLocal -type TicketDepKeyHashid = KeyHashid TicketDependency +type TicketDepKeyHashid = KeyHashid LocalTicketDependency type PatchKeyHashid = KeyHashid Patch -- This is where we define all of the routes in our application. For a full diff --git a/src/Vervis/GraphProxy.hs b/src/Vervis/GraphProxy.hs index 3f4ce88..c9d19ea 100644 --- a/src/Vervis/GraphProxy.hs +++ b/src/Vervis/GraphProxy.hs @@ -29,7 +29,7 @@ -- proxy type directly each time, which may be long and cumbersome. module Vervis.GraphProxy ( GraphProxy - , ticketDepGraph + --, ticketDepGraph ) where @@ -39,5 +39,5 @@ import Vervis.Model type GraphProxy n e = Proxy (n, e) -ticketDepGraph :: GraphProxy Ticket TicketDependency -ticketDepGraph = Proxy +--ticketDepGraph :: GraphProxy Ticket TicketDependency +--ticketDepGraph = Proxy diff --git a/src/Vervis/Handler/Client.hs b/src/Vervis/Handler/Client.hs index bf05aa6..a1265ff 100644 --- a/src/Vervis/Handler/Client.hs +++ b/src/Vervis/Handler/Client.hs @@ -401,10 +401,7 @@ postPublishR = do , ticketIsResolved = False , ticketAttachment = Nothing } - offer = Offer - { offerObject = ticketAP - , offerTarget = encodeRouteFed h $ ProjectR shr prj - } + target = encodeRouteFed h $ ProjectR shr prj audience = Audience { audienceTo = map (encodeRouteFed h) $ recipsA ++ recipsC @@ -414,7 +411,7 @@ postPublishR = do , audienceGeneral = [] , audienceNonActors = map (encodeRouteFed h) recipsC } - ExceptT $ offerTicketC shrAuthor summary audience offer + ExceptT $ offerTicketC shrAuthor summary audience ticketAP target follow shrAuthor (uObject@(ObjURI hObject luObject), uRecip) = do (summary, audience, followAP) <- C.follow shrAuthor uObject uRecip False @@ -741,9 +738,9 @@ postProjectTicketsR shr prj = do -} if offer then Right <$> do - (summary, audience, offer) <- + (summary, audience, ticket, target) <- ExceptT $ offerTicket shrAuthor (TextHtml title) (TextPandocMarkdown desc) shr prj - obiid <- ExceptT $ offerTicketC shrAuthor summary audience offer + obiid <- ExceptT $ offerTicketC shrAuthor summary audience ticket target ExceptT $ runDB $ do mtal <- getValBy $ UniqueTicketAuthorLocalOpen obiid return $ diff --git a/src/Vervis/Handler/Inbox.hs b/src/Vervis/Handler/Inbox.hs index 2ef4929..aff21ff 100644 --- a/src/Vervis/Handler/Inbox.hs +++ b/src/Vervis/Handler/Inbox.hs @@ -80,6 +80,7 @@ import Yesod.ActivityPub import Yesod.Auth.Unverified import Yesod.FedURI import Yesod.Hashids +import Yesod.MonadSite import Yesod.RenderSource import Data.Aeson.Local @@ -267,65 +268,69 @@ getRepoInboxR shr rp = getInbox here getInboxId r <- getValBy404 $ UniqueRepo rp sid return $ repoInbox r -postSharerInboxR :: ShrIdent -> Handler () -postSharerInboxR shrRecip = do - federation <- getsYesod $ appFederation . appSettings - unless federation badMethod - contentTypes <- lookupHeaders "Content-Type" - now <- liftIO getCurrentTime - result <- runExceptT $ do - (auth, body) <- authenticateActivity now - (actbObject body,) <$> handleSharerInbox now shrRecip auth body - recordActivity now result contentTypes - case result of - Left err -> do - logDebug err - sendResponseStatus badRequest400 err - Right _ -> return () - +recordActivity + :: (MonadSite m, SiteEnv m ~ App) + => UTCTime -> Either Text (Object, (Text, w)) -> [ContentType] -> m () recordActivity now result contentTypes = do - macts <- getsYesod appActivities + macts <- asksSite appActivities for_ macts $ \ (size, acts) -> liftIO $ atomically $ modifyTVar' acts $ \ vec -> let (msg, body) = case result of Left t -> (t, "{?}") - Right (o, t) -> (t, encodePretty o) + Right (o, (t, _)) -> (t, encodePretty o) item = ActivityReport now msg contentTypes body vec' = item `V.cons` vec in if V.length vec' > size then V.init vec' else vec' -postProjectInboxR :: ShrIdent -> PrjIdent -> Handler () -postProjectInboxR shrRecip prjRecip = do +handleInbox + :: ( UTCTime + -> ActivityAuthentication + -> ActivityBody + -> ExceptT Text Handler + ( Text + , Maybe (ExceptT Text Worker Text) + ) + ) + -> Handler () +handleInbox handler = do federation <- getsYesod $ appFederation . appSettings unless federation badMethod contentTypes <- lookupHeaders "Content-Type" now <- liftIO getCurrentTime result <- runExceptT $ do (auth, body) <- authenticateActivity now - (actbObject body,) <$> - handleProjectInbox now shrRecip prjRecip auth body + (actbObject body,) <$> handler now auth body recordActivity now result contentTypes case result of - Left _ -> sendResponseStatus badRequest400 () - Right _ -> return () + Left err -> do + logDebug err + sendResponseStatus badRequest400 err + Right (obj, (_, mworker)) -> + for_ mworker $ \ worker -> forkWorker "handleInbox worker" $ do + wait <- asyncWorker $ runExceptT worker + result' <- wait + let result'' = + case result' of + Left e -> Left $ T.pack $ displayException e + Right (Left e) -> Left e + Right (Right t) -> Right (obj, (t, Nothing)) + now' <- liftIO getCurrentTime + recordActivity now' result'' contentTypes + case result'' of + Left err -> logDebug err + Right _ -> return () + +postSharerInboxR :: ShrIdent -> Handler () +postSharerInboxR shrRecip = handleInbox $ handleSharerInbox shrRecip + +postProjectInboxR :: ShrIdent -> PrjIdent -> Handler () +postProjectInboxR shr prj = handleInbox $ handleProjectInbox shr prj postRepoInboxR :: ShrIdent -> RpIdent -> Handler () -postRepoInboxR shrRecip rpRecip = do - federation <- getsYesod $ appFederation . appSettings - unless federation badMethod - contentTypes <- lookupHeaders "Content-Type" - now <- liftIO getCurrentTime - result <- runExceptT $ do - (auth, body) <- authenticateActivity now - (actbObject body,) <$> - handleRepoInbox now shrRecip rpRecip auth body - recordActivity now result contentTypes - case result of - Left _ -> sendResponseStatus badRequest400 () - Right _ -> return () +postRepoInboxR shr rp = handleInbox $ handleRepoInbox shr rp {- jsonField :: (FromJSON a, ToJSON a) => Field Handler a diff --git a/src/Vervis/Handler/Patch.hs b/src/Vervis/Handler/Patch.hs index 24b61d4..ab895f7 100644 --- a/src/Vervis/Handler/Patch.hs +++ b/src/Vervis/Handler/Patch.hs @@ -206,26 +206,25 @@ getSharerPatchDiscussionR shr talkhid = (_, Entity _ lt, _, _, _) <- getSharerPatch404 shr talkhid return $ localTicketDiscuss lt -getSharerPatchDeps - :: Bool -> ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent -getSharerPatchDeps forward shr talkhid = - getDependencyCollection here getTicketId404 forward - where - here = - let route = - if forward then SharerPatchDepsR else SharerPatchReverseDepsR - in route shr talkhid - getTicketId404 = do - (_, _, Entity tid _, _, _) <- getSharerPatch404 shr talkhid - return tid - getSharerPatchDepsR :: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent -getSharerPatchDepsR = getSharerPatchDeps True +getSharerPatchDepsR shr talkhid = + getDependencyCollection here getTicket404 + where + here = SharerPatchDepsR shr talkhid + getTicket404 = do + (_, Entity ltid _, _, _, _) <- getSharerPatch404 shr talkhid + return ltid getSharerPatchReverseDepsR :: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent -getSharerPatchReverseDepsR = getSharerPatchDeps False +getSharerPatchReverseDepsR shr talkhid = + getReverseDependencyCollection here getTicket404 + where + here = SharerPatchDepsR shr talkhid + getTicket404 = do + (_, Entity ltid _, _, _, _) <- getSharerPatch404 shr talkhid + return ltid getSharerPatchFollowersR :: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent @@ -469,30 +468,25 @@ getRepoPatchDiscussionR shr rp ltkhid = (_, _, _, Entity _ lt, _, _, _, _) <- getRepoPatch404 shr rp ltkhid return $ localTicketDiscuss lt -getRepoPatchDeps - :: Bool - -> ShrIdent - -> RpIdent - -> KeyHashid LocalTicket - -> Handler TypedContent -getRepoPatchDeps forward shr rp ltkhid = - getDependencyCollection here getTicketId404 forward - where - here = - let route = - if forward then RepoPatchDepsR else RepoPatchReverseDepsR - in route shr rp ltkhid - getTicketId404 = do - (_, _, Entity tid _, _, _, _, _, _) <- getRepoPatch404 shr rp ltkhid - return tid - getRepoPatchDepsR :: ShrIdent -> RpIdent -> KeyHashid LocalTicket -> Handler TypedContent -getRepoPatchDepsR = getRepoPatchDeps True +getRepoPatchDepsR shr rp ltkhid = + getDependencyCollection here getTicketId404 + where + here = RepoPatchDepsR shr rp ltkhid + getTicketId404 = do + (_, _, _, Entity ltid _, _, _, _, _) <- getRepoPatch404 shr rp ltkhid + return ltid getRepoPatchReverseDepsR :: ShrIdent -> RpIdent -> KeyHashid LocalTicket -> Handler TypedContent -getRepoPatchReverseDepsR = getRepoPatchDeps False +getRepoPatchReverseDepsR shr rp ltkhid = + getReverseDependencyCollection here getTicketId404 + where + here = RepoPatchReverseDepsR shr rp ltkhid + getTicketId404 = do + (_, _, _, Entity ltid _, _, _, _, _) <- getRepoPatch404 shr rp ltkhid + return ltid getRepoPatchFollowersR :: ShrIdent -> RpIdent -> KeyHashid LocalTicket -> Handler TypedContent diff --git a/src/Vervis/Handler/Ticket.hs b/src/Vervis/Handler/Ticket.hs index efda708..d02c3b6 100644 --- a/src/Vervis/Handler/Ticket.hs +++ b/src/Vervis/Handler/Ticket.hs @@ -129,7 +129,7 @@ import Vervis.FedURI import Vervis.Form.Ticket import Vervis.Foundation import Vervis.Handler.Discussion -import Vervis.GraphProxy (ticketDepGraph) +--import Vervis.GraphProxy (ticketDepGraph) import Vervis.Model import Vervis.Model.Ident import Vervis.Model.Ticket @@ -276,13 +276,15 @@ getProjectTicketsR shr prj = selectRep $ do ticketRoute _ _ _ (Right (E.Value h, E.Value lu)) = ObjURI h lu getProjectTicketTreeR :: ShrIdent -> PrjIdent -> Handler Html -getProjectTicketTreeR shr prj = do +getProjectTicketTreeR _shr _prj = error "Ticket tree view disabled for now" + {- (summaries, deps) <- runDB $ do Entity sid _ <- getBy404 $ UniqueSharer shr Entity jid _ <- getBy404 $ UniqueProject prj sid (,) <$> getTicketSummaries Nothing Nothing Nothing jid <*> getTicketDepEdges jid defaultLayout $ ticketTreeDW shr prj summaries deps + -} getProjectTicketNewR :: ShrIdent -> PrjIdent -> Handler Html getProjectTicketNewR shr prj = do @@ -297,8 +299,7 @@ getProjectTicketR :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Ty getProjectTicketR shar proj ltkhid = do mpid <- maybeAuthId ( wshr, wfl, - author, massignee, mcloser, ticket, lticket, tparams, eparams, cparams, - deps, rdeps) <- + author, massignee, mcloser, ticket, lticket, tparams, eparams, cparams) <- runDB $ do (Entity sid sharer, Entity jid project, Entity tid ticket, Entity _ lticket, _etcl, _etpl, author) <- getProjectTicket404 shar proj ltkhid (wshr, wid, wfl) <- do @@ -341,21 +342,10 @@ getProjectTicketR shar proj ltkhid = do tparams <- getTicketTextParams tid wid eparams <- getTicketEnumParams tid wid cparams <- getTicketClasses tid wid - deps <- E.select $ E.from $ \ (dep `E.InnerJoin` t `E.InnerJoin` lt) -> do - E.on $ t E.^. TicketId E.==. lt E.^. LocalTicketTicket - E.on $ dep E.^. TicketDependencyChild E.==. t E.^. TicketId - E.where_ $ dep E.^. TicketDependencyParent E.==. E.val tid - return (lt E.^. LocalTicketId, t) - rdeps <- E.select $ E.from $ \ (dep `E.InnerJoin` t `E.InnerJoin` lt) -> do - E.on $ t E.^. TicketId E.==. lt E.^. LocalTicketTicket - E.on $ dep E.^. TicketDependencyParent E.==. t E.^. TicketId - E.where_ $ dep E.^. TicketDependencyChild E.==. E.val tid - return (lt E.^. LocalTicketId, t) return ( wshr, wfl , author', massignee, mcloser, ticket, lticket , tparams, eparams, cparams - , deps, rdeps ) encodeHid <- getEncodeKeyHashid let desc :: Widget @@ -871,94 +861,20 @@ getProjectTicketReplyR shr prj ltkhid mkhid = do (selectDiscussionId shr prj ltkhid) mid -getTicketDeps - :: Bool -> ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler TypedContent -getTicketDeps forward shr prj ltkhid = do - (deps, rows) <- unzip <$> runDB getDepsFromDB - depsAP <- makeDepsCollection deps - encodeHid <- getEncodeKeyHashid - provideHtmlAndAP depsAP $(widgetFile "ticket/dep/list") - where - getDepsFromDB = do - let from' = - if forward then TicketDependencyParent else TicketDependencyChild - to' = - if forward then TicketDependencyChild else TicketDependencyParent - (_es, _ej, Entity tid _, _elt, _etcl, _etpl, _author) <- getProjectTicket404 shr prj ltkhid - fmap (map toRow) $ E.select $ E.from $ - \ ( td - `E.InnerJoin` t - `E.InnerJoin` lt - `E.InnerJoin` tcl - `E.InnerJoin` tpl - `E.LeftOuterJoin` (tal `E.InnerJoin` p `E.InnerJoin` s) - `E.LeftOuterJoin` (tar `E.InnerJoin` ra `E.InnerJoin` ro `E.InnerJoin` i) - ) -> do - E.on $ ro E.?. RemoteObjectInstance E.==. i E.?. InstanceId - E.on $ ra E.?. RemoteActorIdent E.==. ro E.?. RemoteObjectId - E.on $ tar E.?. TicketAuthorRemoteAuthor E.==. ra E.?. RemoteActorId - E.on $ E.just (tcl E.^. TicketContextLocalId) E.==. tar E.?. TicketAuthorRemoteTicket - E.on $ p E.?. PersonIdent E.==. s E.?. SharerId - E.on $ tal E.?. TicketAuthorLocalAuthor E.==. p E.?. PersonId - E.on $ E.just (lt E.^. LocalTicketId) E.==. tal E.?. TicketAuthorLocalTicket - E.on $ tcl E.^. TicketContextLocalId E.==. tpl E.^. TicketProjectLocalContext - E.on $ t E.^. TicketId E.==. tcl E.^. TicketContextLocalTicket - E.on $ t E.^. TicketId E.==. lt E.^. LocalTicketTicket - E.on $ td E.^. to' E.==. t E.^. TicketId - E.where_ $ td E.^. from' E.==. E.val tid - E.orderBy [E.asc $ t E.^. TicketId] - return - ( td E.^. TicketDependencyId - , lt E.^. LocalTicketId - , s - , i - , ro - , ra - , t E.^. TicketTitle - , t E.^. TicketStatus - ) - where - toRow (E.Value dep, E.Value ltid, ms, mi, mro, mra, E.Value title, E.Value status) = - ( dep - , ( ltid - , case (ms, mi, mro, mra) of - (Just s, Nothing, Nothing, Nothing) -> - Left $ entityVal s - (Nothing, Just i, Just ro, Just ra) -> - Right (entityVal i, entityVal ro, entityVal ra) - _ -> error "Ticket author DB invalid state" - , title - , status - ) - ) - makeDepsCollection tdids = do - encodeRouteLocal <- getEncodeRouteLocal - encodeRouteHome <- getEncodeRouteHome - encodeKeyHashid <- getEncodeKeyHashid - let here = - let route = - if forward - then ProjectTicketDepsR - else ProjectTicketReverseDepsR - in route shr prj ltkhid - return Collection - { collectionId = encodeRouteLocal here - , collectionType = CollectionTypeUnordered - , collectionTotalItems = Just $ length tdids - , collectionCurrent = Nothing - , collectionFirst = Nothing - , collectionLast = Nothing - , collectionItems = - map (encodeRouteHome . TicketDepR . encodeKeyHashid) tdids - } - getProjectTicketDepsR :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler TypedContent -getProjectTicketDepsR = getTicketDeps True +getProjectTicketDepsR shr prj ltkhid = + getDependencyCollection here getLocalTicketId404 + where + here = ProjectTicketDepsR shr prj ltkhid + getLocalTicketId404 = do + (_, _, _, Entity ltid _, _, _, _) <- getProjectTicket404 shr prj ltkhid + return ltid postProjectTicketDepsR :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html -postProjectTicketDepsR shr prj ltkhid = do +postProjectTicketDepsR _shr _prj _ltkhid = error "Temporarily disabled" +{- (_es, Entity jid _, Entity tid _, _elt, _etcl, _etpl, _author) <- runDB $ getProjectTicket404 shr prj ltkhid ((result, widget), enctype) <- runFormPost $ ticketDepForm jid tid case result of @@ -969,11 +885,14 @@ postProjectTicketDepsR shr prj ltkhid = do let td = TicketDependency { ticketDependencyParent = tid , ticketDependencyChild = ctid - , ticketDependencyAuthor = pidAuthor - , ticketDependencySummary = "(A ticket dependency)" , ticketDependencyCreated = now } - insert_ td + tdid <- insert td + insert_ TicketDependencyAuthorLocal + { ticketDependencyAuthorLocalDep = tdid + , ticketDependencyAuthorLocalAuthor = pidAuthor + , ticketDependencyAuthorLocalOpen = obiidOffer? + } trrFix td ticketDepGraph setMessage "Ticket dependency added." redirect $ ProjectTicketR shr prj ltkhid @@ -983,13 +902,16 @@ postProjectTicketDepsR shr prj ltkhid = do FormFailure _l -> do setMessage "Submission failed, see errors below." defaultLayout $(widgetFile "ticket/dep/new") +-} getProjectTicketDepNewR :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html -getProjectTicketDepNewR shr prj ltkhid = do +getProjectTicketDepNewR _shr _prj _ltkhid = error "Currently disabled" + {- (_es, Entity jid _, Entity tid _, _elt, _etcl, _etpl, _author) <- runDB $ getProjectTicket404 shr prj ltkhid ((_result, widget), enctype) <- runFormPost $ ticketDepForm jid tid defaultLayout $(widgetFile "ticket/dep/new") + -} postTicketDepOldR :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> KeyHashid LocalTicket -> Handler Html @@ -1001,7 +923,8 @@ postTicketDepOldR shr prj pnum cnum = do deleteTicketDepOldR :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> KeyHashid LocalTicket -> Handler Html -deleteTicketDepOldR shr prj pnum cnum = do +deleteTicketDepOldR _shr _prj _pnum _cnum = error "Dep deletion disabled for now" +{- runDB $ do (_es, Entity jid _, Entity ptid _, _elt, _etcl, _etpl, _author) <- getProjectTicket404 shr prj pnum @@ -1016,69 +939,86 @@ deleteTicketDepOldR shr prj pnum cnum = do delete tdid setMessage "Ticket dependency removed." redirect $ ProjectTicketDepsR shr prj pnum +-} getProjectTicketReverseDepsR :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler TypedContent -getProjectTicketReverseDepsR = getTicketDeps False +getProjectTicketReverseDepsR shr prj ltkhid = + getReverseDependencyCollection here getLocalTicketId404 + where + here = ProjectTicketReverseDepsR shr prj ltkhid + getLocalTicketId404 = do + (_, _, _, Entity ltid _, _, _, _) <- getProjectTicket404 shr prj ltkhid + return ltid -getTicketDepR :: KeyHashid TicketDependency -> Handler TypedContent +getTicketDepR :: KeyHashid LocalTicketDependency -> Handler TypedContent getTicketDepR tdkhid = do - tdid <- decodeKeyHashid404 tdkhid - ( td, - (sParent, jParent, ltParent), - (sChild, jChild, ltChild), - (sAuthor, pAuthor) - ) <- runDB $ do - tdep <- get404 tdid - (,,,) tdep - <$> getTicket (ticketDependencyParent tdep) - <*> getTicket (ticketDependencyChild tdep) - <*> getAuthor (ticketDependencyAuthor tdep) - encodeRouteLocal <- getEncodeRouteLocal encodeRouteHome <- getEncodeRouteHome - encodeHid <- getEncodeKeyHashid - let ticketRoute s j lt = - ProjectTicketR (sharerIdent s) (projectIdent j) (encodeHid lt) - here = TicketDepR tdkhid + wiRoute <- askWorkItemRoute + hLocal <- asksSite siteInstanceHost + + tdid <- decodeKeyHashid404 tdkhid + (td, author, parent, child) <- runDB $ do + td <- get404 tdid + (td,,,) + <$> getAuthor tdid + <*> getWorkItem ( localTicketDependencyParent td) + <*> getChild tdid + let host = + case author of + Left _ -> hLocal + Right (h, _) -> h tdepAP = AP.TicketDependency { ticketDepId = Just $ encodeRouteHome here - , ticketDepParent = - encodeRouteHome $ ticketRoute sParent jParent ltParent + , ticketDepParent = encodeRouteHome $ wiRoute parent , ticketDepChild = - encodeRouteHome $ ticketRoute sChild jChild ltChild + case child of + Left wi -> encodeRouteHome $ wiRoute wi + Right (h, lu) -> ObjURI h lu , ticketDepAttributedTo = - encodeRouteLocal $ SharerR $ sharerIdent sAuthor - , ticketDepPublished = Just $ ticketDependencyCreated td - , ticketDepUpdated = Just $ ticketDependencyCreated td - , ticketDepSummary = TextHtml $ ticketDependencySummary td + case author of + Left shr -> encodeRouteLocal $ SharerR shr + Right (_h, lu) -> lu + , ticketDepPublished = Just $ localTicketDependencyCreated td + , ticketDepUpdated = Nothing } - - provideHtmlAndAP tdepAP $ redirectToPrettyJSON here + provideHtmlAndAP' host tdepAP $ redirectToPrettyJSON here where - getTicket tid = do - ltid <- do - mltid <- getKeyBy $ UniqueLocalTicket tid - case mltid of - Nothing -> error "No LocalTicket" - Just v -> return v - tclid <- do - mtclid <- getKeyBy $ UniqueTicketContextLocal tid - case mtclid of - Nothing -> error "No TicketContextLocal" - Just v -> return v - tpl <- do - mtpl <- getValBy $ UniqueTicketProjectLocal tclid - case mtpl of - Nothing -> error "No TicketProjectLocal" - Just v -> return v - j <- getJust $ ticketProjectLocalProject tpl - s <- getJust $ projectSharer j - return (s, j, ltid) - getAuthor pid = do - p <- getJust pid - s <- getJust $ personIdent p - return (s, p) + here = TicketDepR tdkhid + getAuthor tdid = do + tda <- requireEitherAlt + (getValBy $ UniqueTicketDependencyAuthorLocal tdid) + (getValBy $ UniqueTicketDependencyAuthorRemote tdid) + "No TDA" + "Both TDAL and TDAR" + bitraverse + (\ tdal -> do + p <- getJust $ ticketDependencyAuthorLocalAuthor tdal + s <- getJust $ personIdent p + return $ sharerIdent s + ) + (\ tdar -> do + ra <- getJust $ ticketDependencyAuthorRemoteAuthor tdar + ro <- getJust $ remoteActorIdent ra + i <- getJust $ remoteObjectInstance ro + return (instanceHost i, remoteObjectIdent ro) + ) + tda + getChild tdid = do + tdc <- requireEitherAlt + (getValBy $ UniqueTicketDependencyChildLocal tdid) + (getValBy $ UniqueTicketDependencyChildRemote tdid) + "No TDC" + "Both TDCL and TDCR" + bitraverse + (getWorkItem . ticketDependencyChildLocalChild) + (\ tdcr -> do + ro <- getJust $ ticketDependencyChildRemoteChild tdcr + i <- getJust $ remoteObjectInstance ro + return (instanceHost i, remoteObjectIdent ro) + ) + tdc getProjectTicketParticipantsR :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler TypedContent @@ -1244,26 +1184,25 @@ getSharerTicketDiscussionR shr talkhid = (_, Entity _ lt, _, _) <- getSharerTicket404 shr talkhid return $ localTicketDiscuss lt -getSharerTicketDeps - :: Bool -> ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent -getSharerTicketDeps forward shr talkhid = - getDependencyCollection here getTicketId404 forward - where - here = - let route = - if forward then SharerTicketDepsR else SharerTicketReverseDepsR - in route shr talkhid - getTicketId404 = do - (_, _, Entity tid _, _) <- getSharerTicket404 shr talkhid - return tid - getSharerTicketDepsR :: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent -getSharerTicketDepsR = getSharerTicketDeps True +getSharerTicketDepsR shr talkhid = + getDependencyCollection here getLocalTicketId404 + where + here = SharerTicketDepsR shr talkhid + getLocalTicketId404 = do + (_, Entity ltid _, _, _) <- getSharerTicket404 shr talkhid + return ltid getSharerTicketReverseDepsR :: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent -getSharerTicketReverseDepsR = getSharerTicketDeps False +getSharerTicketReverseDepsR shr talkhid = + getReverseDependencyCollection here getLocalTicketId404 + where + here = SharerTicketReverseDepsR shr talkhid + getLocalTicketId404 = do + (_, Entity ltid _, _, _) <- getSharerTicket404 shr talkhid + return ltid getSharerTicketFollowersR :: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent diff --git a/src/Vervis/Migration.hs b/src/Vervis/Migration.hs index e587042..93e385f 100644 --- a/src/Vervis/Migration.hs +++ b/src/Vervis/Migration.hs @@ -786,7 +786,7 @@ changes hLocal ctx = summary renderUrl , activityAudience = Audience recips [] [] [] [] [] , activitySpecific = OfferActivity Offer - { offerObject = ticketAP + { offerObject = OfferTicket ticketAP , offerTarget = encodeRouteHome $ ProjectR shrProject prj } @@ -1587,6 +1587,123 @@ changes hLocal ctx = , addFieldPrimOptional "TicketRepoLocal" (Nothing :: Maybe Text) "branch" -- 252 , addEntities model_2020_05_25 + -- 253 + , removeField "TicketDependency" "summary" + -- 254 + , addEntities model_2020_05_28 + -- 255 + , unchecked $ lift $ do + tds <- selectList ([] :: [Filter TicketDependency255]) [] + for_ tds $ \ (Entity tdid td) -> do + let pid = ticketDependency255Author td + p <- getJust pid + obiid <- + insert $ + OutboxItem255 + (person255Outbox p) + (persistJSONObjectFromDoc $ Doc hLocal emptyActivity) + (ticketDependency255Created td) + insert_ $ TicketDependencyAuthorLocal255 tdid pid obiid + -- 256 + , removeField "TicketDependency" "author" + -- 257 + , addEntities model_2020_06_01 + -- 258 + , renameEntity "TicketDependency" "LocalTicketDependency" + -- 259 + , renameUnique + "LocalTicketDependency" + "UniqueTicketDependency" + "UniqueLocalTicketDependency" + -- 260 + , unchecked $ lift $ do + tds <- selectList ([] :: [Filter LocalTicketDependency260]) [] + for_ tds $ \ (Entity tdid td) -> do + let tid = localTicketDependency260Child td + location <- + requireEitherAlt + (getKeyBy $ UniqueLocalTicket260 tid) + (runMaybeT $ do + tclid <- MaybeT $ getKeyBy $ UniqueTicketContextLocal260 tid + tarid <- MaybeT $ getKeyBy $ UniqueTicketAuthorRemote260 tclid + rt <- MaybeT $ getValBy $ UniqueRemoteTicket260 tarid + return $ remoteTicket260Ident rt + ) + "Neither LT nor RT" + "Both LT and RT" + case location of + Left ltid -> insert_ $ TicketDependencyChildLocal260 tdid ltid + Right roid -> insert_ $ TicketDependencyChildRemote260 tdid roid + -- 261 + , removeUnique "LocalTicketDependency" "UniqueLocalTicketDependency" + -- 262 + , removeField "LocalTicketDependency" "child" + -- 263 + , addFieldRefRequired'' + "LocalTicketDependency" + (do did <- insert Discussion263 + fsid <- insert FollowerSet263 + tid <- insert $ Ticket263 Nothing defaultTime "" "" "" Nothing "TSNew" defaultTime Nothing + insertEntity $ LocalTicket263 tid did fsid + ) + (Just $ \ (Entity ltidTemp ltTemp) -> do + tdids <- selectList ([] :: [Filter LocalTicketDependency263]) [] + for_ tdids $ \ (Entity tdid td) -> do + ltid <- do + mltid <- + getKeyBy $ UniqueLocalTicket263 $ + localTicketDependency263Parent td + case mltid of + Nothing -> error "TD with non-local parent" + Just v -> return v + update tdid [LocalTicketDependency263ParentNew =. ltid] + + delete ltidTemp + + delete $ localTicket263Ticket ltTemp + delete $ localTicket263Discuss ltTemp + delete $ localTicket263Followers ltTemp + ) + "parentNew" + "LocalTicket" + -- 264 + , removeField "LocalTicketDependency" "parent" + -- 265 + , renameField "LocalTicketDependency" "parentNew" "parent" + -- 266 + , addFieldRefRequired'' + "LocalTicketDependency" + (do obid <- insert Outbox266 + let doc = persistJSONObjectFromDoc $ Doc hLocal emptyActivity + insertEntity $ OutboxItem266 obid doc defaultTime + ) + (Just $ \ (Entity obiidTemp obiTemp) -> do + tdids <- selectList ([] :: [Filter LocalTicketDependency266]) [] + for_ tdids $ \ (Entity tdid td) -> do + lt <- getJust $ localTicketDependency266Parent td + mtpl <- runMaybeT $ do + tclid <- MaybeT $ getKeyBy $ UniqueTicketContextLocal266 $ localTicket266Ticket lt + _ <- MaybeT $ getBy $ UniqueTicketUnderProjectProject266 tclid + MaybeT $ getValBy $ UniqueTicketProjectLocal266 tclid + tpl <- + case mtpl of + Nothing -> error "No TPL" + Just v -> return v + j <- getJust $ ticketProjectLocal266Project tpl + let doc = persistJSONObjectFromDoc $ Doc hLocal emptyActivity + obiid <- + insert $ + OutboxItem266 + (project266Outbox j) + doc + (localTicketDependency266Created td) + update tdid [LocalTicketDependency266Accept =. obiid] + + delete obiidTemp + delete $ outboxItem266Outbox obiTemp + ) + "accept" + "OutboxItem" ] migrateDB diff --git a/src/Vervis/Migration/Model.hs b/src/Vervis/Migration/Model.hs index 68e8e95..566d0b7 100644 --- a/src/Vervis/Migration/Model.hs +++ b/src/Vervis/Migration/Model.hs @@ -199,6 +199,34 @@ module Vervis.Migration.Model , TicketProjectLocal247Generic (..) , model_2020_05_17 , model_2020_05_25 + , model_2020_05_28 + , OutboxItem255Generic (..) + , Person255Generic (..) + , TicketDependency255 + , TicketDependency255Generic (..) + , TicketDependencyAuthorLocal255Generic (..) + , model_2020_06_01 + , RemoteTicket260Generic (..) + , LocalTicketDependency260 + , LocalTicketDependency260Generic (..) + , TicketDependencyChildLocal260Generic (..) + , TicketDependencyChildRemote260Generic (..) + , Discussion263Generic (..) + , FollowerSet263Generic (..) + , Ticket263Generic (..) + , LocalTicket263Generic (..) + , LocalTicketDependency263 + , LocalTicketDependency263Generic (..) + + , Outbox266Generic (..) + , OutboxItem266Generic (..) + , LocalTicketDependency266 + , LocalTicketDependency266Generic (..) + , LocalTicket266Generic (..) + , TicketContextLocal266Generic (..) + , TicketUnderProject266Generic (..) + , TicketProjectLocal266Generic (..) + , Project266Generic (..) ) where @@ -399,3 +427,18 @@ model_2020_05_17 = $(schema "2020_05_17_patch") model_2020_05_25 :: [Entity SqlBackend] model_2020_05_25 = $(schema "2020_05_25_fwd_sender_repo") + +model_2020_05_28 :: [Entity SqlBackend] +model_2020_05_28 = $(schema "2020_05_28_tda") + +makeEntitiesMigration "255" $(modelFile "migrations/2020_05_28_tda_mig.model") + +model_2020_06_01 :: [Entity SqlBackend] +model_2020_06_01 = $(schema "2020_06_01_tdc") + +makeEntitiesMigration "260" $(modelFile "migrations/2020_06_01_tdc_mig.model") + +makeEntitiesMigration "263" $(modelFile "migrations/2020_06_02_tdp.model") + +makeEntitiesMigration "266" + $(modelFile "migrations/2020_06_15_td_accept.model") diff --git a/src/Vervis/Model.hs b/src/Vervis/Model.hs index 0148e2f..d0cacfd 100644 --- a/src/Vervis/Model.hs +++ b/src/Vervis/Model.hs @@ -81,11 +81,13 @@ instance Hashable RoleId where hashWithSalt salt = hashWithSalt salt . fromSqlKey hash = hash . fromSqlKey +{- instance PersistEntityGraph Ticket TicketDependency where sourceParam = ticketDependencyParent sourceField = TicketDependencyParent destParam = ticketDependencyChild destField = TicketDependencyChild +-} {- instance PersistEntityGraphSelect Ticket TicketDependency where diff --git a/src/Vervis/Patch.hs b/src/Vervis/Patch.hs index cdb0703..22069c9 100644 --- a/src/Vervis/Patch.hs +++ b/src/Vervis/Patch.hs @@ -22,12 +22,15 @@ module Vervis.Patch where import Control.Monad +import Control.Monad.IO.Class import Control.Monad.Trans.Class import Control.Monad.Trans.Maybe +import Control.Monad.Trans.Reader import Data.List.NonEmpty (NonEmpty, nonEmpty) import Data.Maybe import Data.Traversable import Database.Persist +import Database.Persist.Sql import Yesod.Core import Yesod.Hashids @@ -40,9 +43,10 @@ import Vervis.Model import Vervis.Model.Ident getSharerPatch - :: ShrIdent + :: MonadIO m + => ShrIdent -> TicketAuthorLocalId - -> AppDB + -> ReaderT SqlBackend m ( Maybe ( Entity TicketAuthorLocal , Entity LocalTicket @@ -73,7 +77,7 @@ getSharerPatch shr talid = runMaybeT $ do repo <- requireEitherAlt (do mtcl <- lift $ getBy $ UniqueTicketContextLocal tid - for mtcl $ \ etcl@(Entity tclid tcl) -> do + for mtcl $ \ etcl@(Entity tclid _) -> do etrl <- MaybeT $ getBy $ UniqueTicketRepoLocal tclid mtup1 <- lift $ getBy $ UniqueTicketUnderProjectProject tclid mtup2 <- lift $ getBy $ UniqueTicketUnderProjectAuthor talid @@ -114,10 +118,11 @@ getSharerPatch404 shr talkhid = do Just patch -> return patch getRepoPatch - :: ShrIdent + :: MonadIO m + => ShrIdent -> RpIdent -> LocalTicketId - -> AppDB + -> ReaderT SqlBackend m ( Maybe ( Entity Sharer , Entity Repo diff --git a/src/Vervis/Ticket.hs b/src/Vervis/Ticket.hs index e022079..4c98420 100644 --- a/src/Vervis/Ticket.hs +++ b/src/Vervis/Ticket.hs @@ -15,7 +15,7 @@ module Vervis.Ticket ( getTicketSummaries - , getTicketDepEdges + --, getTicketDepEdges , WorkflowFieldFilter (..) , WorkflowFieldSummary (..) , TicketTextParamValue (..) @@ -34,31 +34,42 @@ module Vervis.Ticket , getSharerWorkItems , getDependencyCollection + , getReverseDependencyCollection + + , WorkItem (..) + , getWorkItemRoute + , askWorkItemRoute + , getWorkItem ) where -import Control.Arrow ((***)) import Control.Monad +import Control.Monad.IO.Class import Control.Monad.Trans.Class +import Control.Monad.Trans.Except import Control.Monad.Trans.Maybe +import Control.Monad.Trans.Reader +import Data.Either import Data.Foldable (for_) -import Data.Int import Data.Maybe (isJust) import Data.Text (Text) import Data.Traversable -import Database.Esqueleto +import Database.Persist +import Database.Persist.Sql import Yesod.Core (notFound) import Yesod.Core.Content import Yesod.Persist.Core import qualified Database.Esqueleto as E -import qualified Database.Persist as P +import Network.FedURI import Web.ActivityPub hiding (Ticket, Project) import Yesod.ActivityPub import Yesod.FedURI import Yesod.Hashids +import Yesod.MonadSite +import Control.Monad.Trans.Except.Local import Data.Either.Local import Data.Paginate.Local import Database.Persist.Local @@ -74,65 +85,65 @@ import Vervis.Widget.Ticket (TicketSummary (..)) -- | Get summaries of all the tickets in the given project. getTicketSummaries - :: Maybe (SqlExpr (Entity Ticket) -> SqlExpr (Value Bool)) - -> Maybe (SqlExpr (Entity Ticket) -> [SqlExpr OrderBy]) + :: Maybe (E.SqlExpr (Entity Ticket) -> E.SqlExpr (E.Value Bool)) + -> Maybe (E.SqlExpr (Entity Ticket) -> [E.SqlExpr E.OrderBy]) -> Maybe (Int, Int) -> ProjectId -> AppDB [TicketSummary] getTicketSummaries mfilt morder offlim jid = do - tickets <- select $ from $ + tickets <- E.select $ E.from $ \ ( t - `InnerJoin` lt - `InnerJoin` tcl - `InnerJoin` tpl - `LeftOuterJoin` (tal `InnerJoin` p `InnerJoin` s `LeftOuterJoin` tup) - `LeftOuterJoin` (tar `InnerJoin` ra `InnerJoin` ro `InnerJoin` i) - `InnerJoin` d - `LeftOuterJoin` m + `E.InnerJoin` lt + `E.InnerJoin` tcl + `E.InnerJoin` tpl + `E.LeftOuterJoin` (tal `E.InnerJoin` p `E.InnerJoin` s `E.LeftOuterJoin` tup) + `E.LeftOuterJoin` (tar `E.InnerJoin` ra `E.InnerJoin` ro `E.InnerJoin` i) + `E.InnerJoin` d + `E.LeftOuterJoin` m ) -> do - on $ just (d ^. DiscussionId) ==. m ?. MessageRoot - on $ lt ^. LocalTicketDiscuss ==. d ^. DiscussionId - on $ ro ?. RemoteObjectInstance ==. i ?. InstanceId - on $ ra ?. RemoteActorIdent ==. ro ?. RemoteObjectId - on $ tar ?. TicketAuthorRemoteAuthor ==. ra ?. RemoteActorId - on $ just (tcl ^. TicketContextLocalId) ==. tar ?. TicketAuthorRemoteTicket - on $ tal ?. TicketAuthorLocalId ==. tup ?. TicketUnderProjectAuthor - on $ p ?. PersonIdent ==. s ?. SharerId - on $ tal ?. TicketAuthorLocalAuthor ==. p ?. PersonId - on $ just (lt ^. LocalTicketId) ==. tal ?. TicketAuthorLocalTicket - on $ tcl ^. TicketContextLocalId ==. tpl ^. TicketProjectLocalContext - on $ t ^. TicketId ==. tcl ^. TicketContextLocalTicket - on $ t ^. TicketId ==. lt ^. LocalTicketTicket - where_ $ tpl ^. TicketProjectLocalProject ==. val jid - groupBy - ( t ^. TicketId, lt ^. LocalTicketId - , tal ?. TicketAuthorLocalId, s ?. SharerId, tup ?. TicketUnderProjectId - , ra ?. RemoteActorId, ro ?. RemoteObjectId, i ?. InstanceId + E.on $ E.just (d E.^. DiscussionId) E.==. m E.?. MessageRoot + E.on $ lt E.^. LocalTicketDiscuss E.==. d E.^. DiscussionId + E.on $ ro E.?. RemoteObjectInstance E.==. i E.?. InstanceId + E.on $ ra E.?. RemoteActorIdent E.==. ro E.?. RemoteObjectId + E.on $ tar E.?. TicketAuthorRemoteAuthor E.==. ra E.?. RemoteActorId + E.on $ E.just (tcl E.^. TicketContextLocalId) E.==. tar E.?. TicketAuthorRemoteTicket + E.on $ tal E.?. TicketAuthorLocalId E.==. tup E.?. TicketUnderProjectAuthor + E.on $ p E.?. PersonIdent E.==. s E.?. SharerId + E.on $ tal E.?. TicketAuthorLocalAuthor E.==. p E.?. PersonId + E.on $ E.just (lt E.^. LocalTicketId) E.==. tal E.?. TicketAuthorLocalTicket + E.on $ tcl E.^. TicketContextLocalId E.==. tpl E.^. TicketProjectLocalContext + E.on $ t E.^. TicketId E.==. tcl E.^. TicketContextLocalTicket + E.on $ t E.^. TicketId E.==. lt E.^. LocalTicketTicket + E.where_ $ tpl E.^. TicketProjectLocalProject E.==. E.val jid + E.groupBy + ( t E.^. TicketId, lt E.^. LocalTicketId + , tal E.?. TicketAuthorLocalId, s E.?. SharerId, tup E.?. TicketUnderProjectId + , ra E.?. RemoteActorId, ro E.?. RemoteObjectId, i E.?. InstanceId ) - for_ mfilt $ \ filt -> where_ $ filt t - for_ morder $ \ order -> orderBy $ order t + for_ mfilt $ \ filt -> E.where_ $ filt t + for_ morder $ \ order -> E.orderBy $ order t for_ offlim $ \ (off, lim) -> do - offset $ fromIntegral off - limit $ fromIntegral lim + E.offset $ fromIntegral off + E.limit $ fromIntegral lim return - ( t ^. TicketId - , lt ^. LocalTicketId - , tal ?. TicketAuthorLocalId + ( t E.^. TicketId + , lt E.^. LocalTicketId + , tal E.?. TicketAuthorLocalId , s - , tup ?. TicketUnderProjectId + , tup E.?. TicketUnderProjectId , i , ro , ra - , t ^. TicketCreated - , t ^. TicketTitle - , t ^. TicketStatus - , count $ m ?. MessageId + , t E.^. TicketCreated + , t E.^. TicketTitle + , t E.^. TicketStatus + , E.count $ m E.?. MessageId ) for tickets $ - \ (Value tid, Value ltid, Value mtalid, ms, Value mtupid, mi, mro, mra, Value c, Value t, Value d, Value r) -> do - labels <- select $ from $ \ (tpc `InnerJoin` wf) -> do - on $ tpc ^. TicketParamClassField ==. wf ^. WorkflowFieldId - where_ $ tpc ^. TicketParamClassTicket ==. val tid + \ (E.Value tid, E.Value ltid, E.Value mtalid, ms, E.Value mtupid, mi, mro, mra, E.Value c, E.Value t, E.Value d, E.Value r) -> do + labels <- E.select $ E.from $ \ (tpc `E.InnerJoin` wf) -> do + E.on $ tpc E.^. TicketParamClassField E.==. wf E.^. WorkflowFieldId + E.where_ $ tpc E.^. TicketParamClassTicket E.==. E.val tid return wf return TicketSummary { tsId = ltid @@ -156,6 +167,7 @@ getTicketSummaries mfilt morder offlim jid = do -- | Get the child-parent ticket number pairs of all the ticket dependencies -- in the given project, in ascending order by child, and then ascending order -- by parent. +{- getTicketDepEdges :: ProjectId -> AppDB [(Int64, Int64)] getTicketDepEdges jid = fmap (map $ fromSqlKey . unValue *** fromSqlKey . unValue) $ @@ -175,6 +187,7 @@ getTicketDepEdges jid = tpl2 ^. TicketProjectLocalProject ==. val jid orderBy [asc $ t1 ^. TicketId, asc $ t2 ^. TicketId] return (t1 ^. TicketId, t2 ^. TicketId) +-} data WorkflowFieldFilter = WorkflowFieldFilter { wffNew :: Bool @@ -202,29 +215,29 @@ data TicketTextParam = TicketTextParam } toTParam - :: ( Value WorkflowFieldId - , Value FldIdent - , Value Text - , Value Bool - , Value Bool - , Value Bool - , Value Bool - , Value Bool - , Value (Maybe TicketParamTextId) - , Value (Maybe Text) + :: ( E.Value WorkflowFieldId + , E.Value FldIdent + , E.Value Text + , E.Value Bool + , E.Value Bool + , E.Value Bool + , E.Value Bool + , E.Value Bool + , E.Value (Maybe TicketParamTextId) + , E.Value (Maybe Text) ) -> TicketTextParam toTParam - ( Value fid - , Value fld - , Value name - , Value req - , Value con - , Value new - , Value todo - , Value closed - , Value mp - , Value mt + ( E.Value fid + , E.Value fld + , E.Value name + , E.Value req + , E.Value con + , E.Value new + , E.Value todo + , E.Value closed + , E.Value mp + , E.Value mt ) = TicketTextParam { ttpField = WorkflowFieldSummary @@ -252,25 +265,25 @@ toTParam getTicketTextParams :: TicketId -> WorkflowId -> AppDB [TicketTextParam] getTicketTextParams tid wid = fmap (map toTParam) $ - select $ from $ \ (p `RightOuterJoin` f) -> do - on $ - p ?. TicketParamTextField ==. just (f ^. WorkflowFieldId) &&. - p ?. TicketParamTextTicket ==. just (val tid) - where_ $ - f ^. WorkflowFieldWorkflow ==. val wid &&. - f ^. WorkflowFieldType ==. val WFTText &&. - isNothing (f ^. WorkflowFieldEnm) + E.select $ E.from $ \ (p `E.RightOuterJoin` f) -> do + E.on $ + p E.?. TicketParamTextField E.==. E.just (f E.^. WorkflowFieldId) E.&&. + p E.?. TicketParamTextTicket E.==. E.just (E.val tid) + E.where_ $ + f E.^. WorkflowFieldWorkflow E.==. E.val wid E.&&. + f E.^. WorkflowFieldType E.==. E.val WFTText E.&&. + E.isNothing (f E.^. WorkflowFieldEnm) return - ( f ^. WorkflowFieldId - , f ^. WorkflowFieldIdent - , f ^. WorkflowFieldName - , f ^. WorkflowFieldRequired - , f ^. WorkflowFieldConstant - , f ^. WorkflowFieldFilterNew - , f ^. WorkflowFieldFilterTodo - , f ^. WorkflowFieldFilterClosed - , p ?. TicketParamTextId - , p ?. TicketParamTextValue + ( f E.^. WorkflowFieldId + , f E.^. WorkflowFieldIdent + , f E.^. WorkflowFieldName + , f E.^. WorkflowFieldRequired + , f E.^. WorkflowFieldConstant + , f E.^. WorkflowFieldFilterNew + , f E.^. WorkflowFieldFilterTodo + , f E.^. WorkflowFieldFilterClosed + , p E.?. TicketParamTextId + , p E.?. TicketParamTextValue ) data WorkflowEnumSummary = WorkflowEnumSummary @@ -291,35 +304,35 @@ data TicketEnumParam = TicketEnumParam } toEParam - :: ( Value WorkflowFieldId - , Value FldIdent - , Value Text - , Value Bool - , Value Bool - , Value Bool - , Value Bool - , Value Bool - , Value WorkflowEnumId - , Value EnmIdent - , Value (Maybe TicketParamEnumId) - , Value (Maybe WorkflowEnumCtorId) - , Value (Maybe Text) + :: ( E.Value WorkflowFieldId + , E.Value FldIdent + , E.Value Text + , E.Value Bool + , E.Value Bool + , E.Value Bool + , E.Value Bool + , E.Value Bool + , E.Value WorkflowEnumId + , E.Value EnmIdent + , E.Value (Maybe TicketParamEnumId) + , E.Value (Maybe WorkflowEnumCtorId) + , E.Value (Maybe Text) ) -> TicketEnumParam toEParam - ( Value fid - , Value fld - , Value name - , Value req - , Value con - , Value new - , Value todo - , Value closed - , Value i - , Value e - , Value mp - , Value mc - , Value mt + ( E.Value fid + , E.Value fld + , E.Value name + , E.Value req + , E.Value con + , E.Value new + , E.Value todo + , E.Value closed + , E.Value i + , E.Value e + , E.Value mp + , E.Value mc + , E.Value mt ) = TicketEnumParam { tepField = WorkflowFieldSummary @@ -352,32 +365,32 @@ toEParam getTicketEnumParams :: TicketId -> WorkflowId -> AppDB [TicketEnumParam] getTicketEnumParams tid wid = fmap (map toEParam) $ - select $ from $ \ (p `InnerJoin` c `RightOuterJoin` f `InnerJoin` e) -> do - on $ - e ^. WorkflowEnumWorkflow ==. val wid &&. - f ^. WorkflowFieldEnm ==. just (e ^. WorkflowEnumId) - on $ - f ^. WorkflowFieldWorkflow ==. val wid &&. - f ^. WorkflowFieldType ==. val WFTEnum &&. - p ?. TicketParamEnumField ==. just (f ^. WorkflowFieldId) &&. - c ?. WorkflowEnumCtorEnum ==. f ^. WorkflowFieldEnm - on $ - p ?. TicketParamEnumTicket ==. just (val tid) &&. - p ?. TicketParamEnumValue ==. c ?. WorkflowEnumCtorId + E.select $ E.from $ \ (p `E.InnerJoin` c `E.RightOuterJoin` f `E.InnerJoin` e) -> do + E.on $ + e E.^. WorkflowEnumWorkflow E.==. E.val wid E.&&. + f E.^. WorkflowFieldEnm E.==. E.just (e E.^. WorkflowEnumId) + E.on $ + f E.^. WorkflowFieldWorkflow E.==. E.val wid E.&&. + f E.^. WorkflowFieldType E.==. E.val WFTEnum E.&&. + p E.?. TicketParamEnumField E.==. E.just (f E.^. WorkflowFieldId) E.&&. + c E.?. WorkflowEnumCtorEnum E.==. f E.^. WorkflowFieldEnm + E.on $ + p E.?. TicketParamEnumTicket E.==. E.just (E.val tid) E.&&. + p E.?. TicketParamEnumValue E.==. c E.?. WorkflowEnumCtorId return - ( f ^. WorkflowFieldId - , f ^. WorkflowFieldIdent - , f ^. WorkflowFieldName - , f ^. WorkflowFieldRequired - , f ^. WorkflowFieldConstant - , f ^. WorkflowFieldFilterNew - , f ^. WorkflowFieldFilterTodo - , f ^. WorkflowFieldFilterClosed - , e ^. WorkflowEnumId - , e ^. WorkflowEnumIdent - , p ?. TicketParamEnumId - , c ?. WorkflowEnumCtorId - , c ?. WorkflowEnumCtorName + ( f E.^. WorkflowFieldId + , f E.^. WorkflowFieldIdent + , f E.^. WorkflowFieldName + , f E.^. WorkflowFieldRequired + , f E.^. WorkflowFieldConstant + , f E.^. WorkflowFieldFilterNew + , f E.^. WorkflowFieldFilterTodo + , f E.^. WorkflowFieldFilterClosed + , e E.^. WorkflowEnumId + , e E.^. WorkflowEnumIdent + , p E.?. TicketParamEnumId + , c E.?. WorkflowEnumCtorId + , c E.?. WorkflowEnumCtorName ) data TicketClassParam = TicketClassParam @@ -386,27 +399,27 @@ data TicketClassParam = TicketClassParam } toCParam - :: ( Value WorkflowFieldId - , Value FldIdent - , Value Text - , Value Bool - , Value Bool - , Value Bool - , Value Bool - , Value Bool - , Value (Maybe TicketParamClassId) + :: ( E.Value WorkflowFieldId + , E.Value FldIdent + , E.Value Text + , E.Value Bool + , E.Value Bool + , E.Value Bool + , E.Value Bool + , E.Value Bool + , E.Value (Maybe TicketParamClassId) ) -> TicketClassParam toCParam - ( Value fid - , Value fld - , Value name - , Value req - , Value con - , Value new - , Value todo - , Value closed - , Value mp + ( E.Value fid + , E.Value fld + , E.Value name + , E.Value req + , E.Value con + , E.Value new + , E.Value todo + , E.Value closed + , E.Value mp ) = TicketClassParam { tcpField = WorkflowFieldSummary { wfsId = fid @@ -425,30 +438,31 @@ toCParam getTicketClasses :: TicketId -> WorkflowId -> AppDB [TicketClassParam] getTicketClasses tid wid = fmap (map toCParam) $ - select $ from $ \ (p `RightOuterJoin` f) -> do - on $ - p ?. TicketParamClassField ==. just (f ^. WorkflowFieldId) &&. - p ?. TicketParamClassTicket ==. just (val tid) - where_ $ - f ^. WorkflowFieldWorkflow ==. val wid &&. - f ^. WorkflowFieldType ==. val WFTClass &&. - isNothing (f ^. WorkflowFieldEnm) + E.select $ E.from $ \ (p `E.RightOuterJoin` f) -> do + E.on $ + p E.?. TicketParamClassField E.==. E.just (f E.^. WorkflowFieldId) E.&&. + p E.?. TicketParamClassTicket E.==. E.just (E.val tid) + E.where_ $ + f E.^. WorkflowFieldWorkflow E.==. E.val wid E.&&. + f E.^. WorkflowFieldType E.==. E.val WFTClass E.&&. + E.isNothing (f E.^. WorkflowFieldEnm) return - ( f ^. WorkflowFieldId - , f ^. WorkflowFieldIdent - , f ^. WorkflowFieldName - , f ^. WorkflowFieldRequired - , f ^. WorkflowFieldConstant - , f ^. WorkflowFieldFilterNew - , f ^. WorkflowFieldFilterTodo - , f ^. WorkflowFieldFilterClosed - , p ?. TicketParamClassId + ( f E.^. WorkflowFieldId + , f E.^. WorkflowFieldIdent + , f E.^. WorkflowFieldName + , f E.^. WorkflowFieldRequired + , f E.^. WorkflowFieldConstant + , f E.^. WorkflowFieldFilterNew + , f E.^. WorkflowFieldFilterTodo + , f E.^. WorkflowFieldFilterClosed + , p E.?. TicketParamClassId ) getSharerTicket - :: ShrIdent + :: MonadIO m + => ShrIdent -> TicketAuthorLocalId - -> AppDB + -> ReaderT SqlBackend m ( Maybe ( Entity TicketAuthorLocal , Entity LocalTicket @@ -472,12 +486,12 @@ getSharerTicket shr talid = runMaybeT $ do lt <- lift $ getJust ltid let tid = localTicketTicket lt t <- lift $ getJust tid - npatches <- lift $ P.count [PatchTicket P.==. tid] + npatches <- lift $ count [PatchTicket ==. tid] guard $ npatches <= 0 project <- requireEitherAlt (do mtcl <- lift $ getBy $ UniqueTicketContextLocal tid - for mtcl $ \ etcl@(Entity tclid tcl) -> do + for mtcl $ \ etcl@(Entity tclid _) -> do etpl <- MaybeT $ getBy $ UniqueTicketProjectLocal tclid mtup1 <- lift $ getBy $ UniqueTicketUnderProjectProject tclid mtup2 <- lift $ getBy $ UniqueTicketUnderProjectAuthor talid @@ -517,10 +531,11 @@ getSharerTicket404 shr talkhid = do Just ticket -> return ticket getProjectTicket - :: ShrIdent + :: MonadIO m + => ShrIdent -> PrjIdent -> LocalTicketId - -> AppDB + -> ReaderT SqlBackend m ( Maybe ( Entity Sharer , Entity Project @@ -542,7 +557,7 @@ getProjectTicket shr prj ltid = runMaybeT $ do etcl@(Entity tclid _) <- MaybeT $ getBy $ UniqueTicketContextLocal tid etpl@(Entity _ tpl) <- MaybeT $ getBy $ UniqueTicketProjectLocal tclid guard $ ticketProjectLocalProject tpl == jid - npatches <- lift $ P.count [PatchTicket P.==. tid] + npatches <- lift $ count [PatchTicket ==. tid] guard $ npatches <= 0 author <- requireEitherAlt @@ -586,7 +601,7 @@ getSharerWorkItems => (ShrIdent -> Route App) -> (ShrIdent -> KeyHashid record -> Route App) -> (PersonId -> AppDB Int) - -> (PersonId -> Int -> Int -> AppDB [Value (Key record)]) + -> (PersonId -> Int -> Int -> AppDB [E.Value (Key record)]) -> ShrIdent -> Handler TypedContent getSharerWorkItems mkhere itemRoute countItems selectItems shr = do @@ -632,37 +647,170 @@ getSharerWorkItems mkhere itemRoute countItems selectItems shr = do else Nothing , collectionPageStartIndex = Nothing , collectionPageItems = - map (encodeRouteHome . ticketUrl . unValue) tickets + map (encodeRouteHome . ticketUrl . E.unValue) tickets } where provide :: ActivityPub a => Route App -> a URIMode -> Handler TypedContent provide here a = provideHtmlAndAP a $ redirectToPrettyJSON here getDependencyCollection - :: Route App -> AppDB TicketId -> Bool -> Handler TypedContent -getDependencyCollection here getTicketId404 forward = do + :: Route App -> AppDB LocalTicketId -> Handler TypedContent +getDependencyCollection here getLocalTicketId404 = do tdids <- runDB $ do - tid <- getTicketId404 - let (from, to) = - if forward - then (TicketDependencyParent, TicketDependencyChild) - else (TicketDependencyChild, TicketDependencyParent) - E.select $ E.from $ \ (td `E.InnerJoin` t) -> do - E.on $ td E.^. to E.==. t E.^. TicketId - E.where_ $ td E.^. from E.==. E.val tid - return $ td E.^. TicketDependencyId + ltid <- getLocalTicketId404 + selectKeysList + [LocalTicketDependencyParent ==. ltid] + [Desc LocalTicketDependencyId] + encodeRouteLocal <- getEncodeRouteLocal + encodeRouteHome <- getEncodeRouteHome + encodeHid <- getEncodeKeyHashid + let deps = Collection + { collectionId = encodeRouteLocal here + , collectionType = CollectionTypeOrdered + , collectionTotalItems = Just $ length tdids + , collectionCurrent = Nothing + , collectionFirst = Nothing + , collectionLast = Nothing + , collectionItems = + map (encodeRouteHome . TicketDepR . encodeHid) tdids + } + provideHtmlAndAP deps $ redirectToPrettyJSON here + +getReverseDependencyCollection + :: Route App -> AppDB LocalTicketId -> Handler TypedContent +getReverseDependencyCollection here getLocalTicketId404 = do + (locals, remotes) <- runDB $ do + ltid <- getLocalTicketId404 + (,) <$> getLocals ltid <*> getRemotes ltid encodeRouteLocal <- getEncodeRouteLocal encodeRouteHome <- getEncodeRouteHome encodeHid <- getEncodeKeyHashid let deps = Collection { collectionId = encodeRouteLocal here , collectionType = CollectionTypeUnordered - , collectionTotalItems = Just $ length tdids + , collectionTotalItems = Just $ length locals + length remotes , collectionCurrent = Nothing , collectionFirst = Nothing , collectionLast = Nothing , collectionItems = - map (encodeRouteHome . TicketDepR . encodeHid . E.unValue) - tdids + map (encodeRouteHome . TicketDepR . encodeHid) locals ++ + map (\ (E.Value h, E.Value lu) -> ObjURI h lu) remotes } provideHtmlAndAP deps $ redirectToPrettyJSON here + where + getLocals ltid = + map (ticketDependencyChildLocalDep . entityVal) <$> + selectList [TicketDependencyChildLocalChild ==. ltid] [] + getRemotes ltid = + E.select $ E.from $ \ (rtd `E.InnerJoin` ro `E.InnerJoin` i) -> do + E.on $ ro E.^. RemoteObjectInstance E.==. i E.^. InstanceId + E.on $ rtd E.^. RemoteTicketDependencyIdent E.==. ro E.^. RemoteObjectId + E.where_ $ rtd E.^. RemoteTicketDependencyChild E.==. E.val ltid + return (i E.^. InstanceHost, ro E.^. RemoteObjectIdent) + +data WorkItem + = WorkItemSharerTicket ShrIdent TicketAuthorLocalId Bool + | WorkItemProjectTicket ShrIdent PrjIdent LocalTicketId + | WorkItemRepoPatch ShrIdent RpIdent LocalTicketId + deriving Eq + +getWorkItemRoute + :: (MonadSite m, YesodHashids (SiteEnv m)) => WorkItem -> m (Route App) +getWorkItemRoute wi = ($ wi) <$> askWorkItemRoute + +askWorkItemRoute + :: (MonadSite m, YesodHashids (SiteEnv m)) => m (WorkItem -> Route App) +askWorkItemRoute = do + hashTALID <- getEncodeKeyHashid + hashLTID <- getEncodeKeyHashid + let route (WorkItemSharerTicket shr talid False) = SharerTicketR shr (hashTALID talid) + route (WorkItemSharerTicket shr talid True) = SharerPatchR shr (hashTALID talid) + route (WorkItemProjectTicket shr prj ltid) = ProjectTicketR shr prj (hashLTID ltid) + route (WorkItemRepoPatch shr rp ltid) = RepoPatchR shr rp (hashLTID ltid) + return route + +getWorkItem :: MonadIO m => LocalTicketId -> ReaderT SqlBackend m WorkItem +getWorkItem ltid = (either error return =<<) $ runExceptT $ do + lt <- lift $ getJust ltid + let tid = localTicketTicket lt + + metal <- lift $ getBy $ UniqueTicketAuthorLocal ltid + mremoteContext <- + case metal of + Nothing -> return Nothing + Just (Entity talid _) -> lift $ do + metcr <- getBy (UniqueTicketProjectRemote talid) + for metcr $ \ etcr -> + (etcr,) . (> 0) <$> count [PatchTicket ==. tid] + mlocalContext <- do + metcl <- lift $ getBy $ UniqueTicketContextLocal tid + for metcl $ \ etcl@(Entity tclid _) -> do + npatches <- lift $ count [PatchTicket ==. tid] + metpl <- lift $ getBy $ UniqueTicketProjectLocal tclid + metrl <- lift $ getBy $ UniqueTicketRepoLocal tclid + case (metpl, metrl) of + (Nothing, Nothing) -> throwE "TCL but no TPL and no TRL" + (Just etpl, Nothing) -> do + when (npatches > 0) $ throwE "TPL but patches attached" + return (etcl, Left etpl) + (Nothing, Just etrl) -> do + when (npatches < 1) $ throwE "TRL but no patches attached" + return (etcl, Right etrl) + (Just _, Just _) -> throwE "Both TPL and TRL" + metar <- + case mlocalContext of + Nothing -> return Nothing + Just (Entity tclid _, _) -> + lift $ getBy $ UniqueTicketAuthorRemote tclid + + mert <- + case metar of + Nothing -> return Nothing + Just (Entity tarid _) -> lift $ getBy $ UniqueRemoteTicket tarid + + metuc <- + case (metal, mlocalContext) of + (Nothing, Nothing) -> return Nothing + (Just (Entity talid _), Nothing) -> do + mtuc <- lift $ getBy $ UniqueTicketUnderProjectAuthor talid + for mtuc $ \ _ -> throwE "No TCL, but TUC exists for TAL" + (Nothing, Just (Entity tclid _, _)) -> do + mtuc <- lift $ getBy $ UniqueTicketUnderProjectProject tclid + for mtuc $ \ _ -> throwE "No TAL, but TUC exists for TCL" + (Just (Entity talid _), Just (Entity tclid _, _)) -> do + metuc1 <- lift $ getBy $ UniqueTicketUnderProjectAuthor talid + mtucid2 <- lift $ getKeyBy $ UniqueTicketUnderProjectProject tclid + case (metuc1, mtucid2) of + (Nothing, Nothing) -> return Nothing + (Just _, Nothing) -> throwE "TAL has TUC, TCL doesn't" + (Nothing, Just _) -> throwE "TCL has TUC, TAL doesn't" + (Just etuc, Just tucid) -> + if entityKey etuc == tucid + then return $ Just etuc + else throwE "TAL and TCL have different TUCs" + + verifyNothingE mert "Ticket has both LT and RT" + + case (mremoteContext, metal, mlocalContext, metar) of + (Nothing, Just etal, Just (_, ctx), Nothing) -> + lift $ + case metuc of + Nothing -> authorHosted etal (isRight ctx) + Just _ -> contextHosted ctx + (Nothing, Nothing, Just (_, ctx), Just _) -> lift $ contextHosted ctx + (Just (_, patch), Just etal, Nothing, Nothing) -> + lift $ authorHosted etal patch + _ -> throwE "Invalid/unexpected context/author situation" + where + contextHosted (Left (Entity _ tpl)) = do + j <- getJust $ ticketProjectLocalProject tpl + s <- getJust $ projectSharer j + return $ WorkItemProjectTicket (sharerIdent s) (projectIdent j) ltid + contextHosted (Right (Entity _ trl)) = do + r <- getJust $ ticketRepoLocalRepo trl + s <- getJust $ repoSharer r + return $ WorkItemRepoPatch (sharerIdent s) (repoIdent r) ltid + authorHosted (Entity talid tal) patch = do + p <- getJust $ ticketAuthorLocalAuthor tal + s <- getJust $ personIdent p + return $ WorkItemSharerTicket (sharerIdent s) talid patch diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index d00f629..b7f2644 100644 --- a/src/Web/ActivityPub.hs +++ b/src/Web/ActivityPub.hs @@ -61,6 +61,7 @@ module Web.ActivityPub , CreateObject (..) , Create (..) , Follow (..) + , OfferObject (..) , Offer (..) , Push (..) , Reject (..) @@ -84,6 +85,7 @@ module Web.ActivityPub , httpPostAP , httpPostAPBytes , Fetched (..) + , fetchAP , fetchAPID , fetchAPID' , fetchRecipient @@ -91,6 +93,8 @@ module Web.ActivityPub , fetchUnknownKey , fetchKnownPersonalKey , fetchKnownSharedKey + + , Obj (..) ) where @@ -733,7 +737,6 @@ data Relationship u = Relationship , relationshipAttributedTo :: LocalURI , relationshipPublished :: Maybe UTCTime , relationshipUpdated :: Maybe UTCTime - , relationshipSummary :: TextHtml } instance ActivityPub Relationship where @@ -755,11 +758,10 @@ instance ActivityPub Relationship where <*> pure attributedTo <*> o .:? "published" <*> o .:? "updated" - <*> (TextHtml . sanitizeBalance <$> o .: "summary") toSeries authority (Relationship id_ typs subject property object attributedTo published - updated summary) + updated) = "id" .=? id_ <> "type" .= ("Relationship" : typs) <> "subject" .= subject @@ -768,7 +770,6 @@ instance ActivityPub Relationship where <> "attributedTo" .= ObjURI authority attributedTo <> "published" .=? published <> "updated" .=? updated - <> "summary" .= summary data TicketDependency u = TicketDependency { ticketDepId :: Maybe (ObjURI u) @@ -777,7 +778,6 @@ data TicketDependency u = TicketDependency , ticketDepAttributedTo :: LocalURI , ticketDepPublished :: Maybe UTCTime , ticketDepUpdated :: Maybe UTCTime - , ticketDepSummary :: TextHtml } instance ActivityPub TicketDependency where @@ -799,7 +799,6 @@ instance ActivityPub TicketDependency where , ticketDepAttributedTo = relationshipAttributedTo rel , ticketDepPublished = relationshipPublished rel , ticketDepUpdated = relationshipUpdated rel - , ticketDepSummary = relationshipSummary rel } toSeries a = toSeries a . td2rel @@ -813,7 +812,6 @@ instance ActivityPub TicketDependency where , relationshipAttributedTo = ticketDepAttributedTo td , relationshipPublished = ticketDepPublished td , relationshipUpdated = ticketDepUpdated td - , relationshipSummary = ticketDepSummary td } newtype TextHtml = TextHtml @@ -893,6 +891,7 @@ parseTicketLocal o = do Nothing -> do verifyNothing "replies" verifyNothing "participants" + verifyNothing "followers" verifyNothing "team" verifyNothing "history" verifyNothing "dependencies" @@ -903,7 +902,7 @@ parseTicketLocal o = do TicketLocal <$> pure id_ <*> withAuthorityO a (o .: "replies") - <*> withAuthorityO a (o .: "participants") + <*> withAuthorityO a (o .: "participants" <|> o .: "followers") <*> withAuthorityMaybeO a (o .:? "team") <*> withAuthorityO a (o .: "history") <*> withAuthorityO a (o .: "dependencies") @@ -916,10 +915,10 @@ parseTicketLocal o = do encodeTicketLocal :: UriMode u => Authority u -> TicketLocal -> Series encodeTicketLocal - a (TicketLocal id_ replies participants team events deps rdeps) + a (TicketLocal id_ replies followers team events deps rdeps) = "id" .= ObjURI a id_ <> "replies" .= ObjURI a replies - <> "participants" .= ObjURI a participants + <> "followers" .= ObjURI a followers <> "team" .=? (ObjURI a <$> team) <> "history" .= ObjURI a events <> "dependencies" .= ObjURI a deps @@ -1220,23 +1219,38 @@ encodeFollow (Follow obj mcontext hide) <> "context" .=? mcontext <> "hide" .= hide +data OfferObject u = OfferTicket (Ticket u) | OfferDep (TicketDependency u) + +instance ActivityPub OfferObject where + jsonldContext = error "jsonldContext OfferObject" + parseObject o + = second OfferTicket <$> parseObject o + <|> second OfferDep <$> parseObject o + toSeries h (OfferTicket t) = toSeries h t + toSeries h (OfferDep d) = toSeries h d + data Offer u = Offer - { offerObject :: Ticket u + { offerObject :: OfferObject u , offerTarget :: ObjURI u } parseOffer :: UriMode u => Object -> Authority u -> LocalURI -> Parser (Offer u) parseOffer o a luActor = do - ticket <- withAuthorityT a $ parseObject =<< o .: "object" - unless (luActor == ticketAttributedTo ticket) $ - fail "Offer actor != Ticket attrib" + obj <- withAuthorityT a $ parseObject =<< o .: "object" target@(ObjURI hTarget luTarget) <- o .: "target" - for_ (ticketContext ticket) $ \ (ObjURI hContext luContext) -> do - unless (hTarget == hContext) $ - fail "Offer target host != Ticket context host" - unless (luTarget == luContext) $ - fail "Offer target != Ticket context" - return $ Offer ticket target + case obj of + OfferTicket ticket -> do + unless (luActor == ticketAttributedTo ticket) $ + fail "Offer actor != Ticket attrib" + for_ (ticketContext ticket) $ \ (ObjURI hContext luContext) -> do + unless (hTarget == hContext) $ + fail "Offer target host != Ticket context host" + unless (luTarget == luContext) $ + fail "Offer target != Ticket context" + OfferDep dep -> do + unless (luActor == ticketDepAttributedTo dep) $ + fail "Offer actor != TicketDependency attrib" + return $ Offer obj target encodeOffer :: UriMode u => Authority u -> LocalURI -> Offer u -> Series encodeOffer authority actor (Offer obj target) @@ -1821,3 +1835,23 @@ fetchKnownSharedKey manager malgo host luActor luKey = do -> Either (PublicKey u) (Actor u) -> Either (PublicKey u) (Actor u) asKeyOrActor _ = id + +data Obj u = Obj + { objId :: ObjURI u + , objType :: Text + + , objContext :: Maybe (ObjURI u) + , objFollowers :: Maybe LocalURI + , objInbox :: Maybe LocalURI + , objTeam :: Maybe LocalURI + } + +instance UriMode u => FromJSON (Obj u) where + parseJSON = withObject "Obj" $ \ o -> do + id_@(ObjURI h _) <- o .: "id" <|> o .: "@id" + Obj id_ + <$> (o .: "type" <|> o .: "@type") + <*> o .:? "context" + <*> withAuthorityMaybeO h (o .:? "followers") + <*> withAuthorityMaybeO h (o .:? "inbox") + <*> withAuthorityMaybeO h (o .:? "team") diff --git a/src/Yesod/MonadSite.hs b/src/Yesod/MonadSite.hs index bd43d1c..d5ec64d 100644 --- a/src/Yesod/MonadSite.hs +++ b/src/Yesod/MonadSite.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2019 by fr33domlover . + - Written in 2019, 2020 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -22,6 +22,8 @@ module Yesod.MonadSite , askUrlRender , asksSite , runSiteDB + , runSiteDBExcept + , runDBExcept , WorkerT () , runWorkerT , WorkerFor @@ -31,7 +33,6 @@ module Yesod.MonadSite ) where -import Control.Exception import Control.Monad.Fail import Control.Monad.IO.Class import Control.Monad.IO.Unlift @@ -44,6 +45,7 @@ import Data.Functor import Data.Text (Text) import Database.Persist.Sql import UnliftIO.Async +import UnliftIO.Exception import UnliftIO.Concurrent import Yesod.Core hiding (logError) import Yesod.Core.Types @@ -104,6 +106,36 @@ runSiteDB action = do site <- askSite runPool (sitePersistConfig site) action (sitePersistPool site) +newtype FedError = FedError Text deriving Show + +instance Exception FedError + +runSiteDBExcept + :: ( MonadUnliftIO m + , MonadSite m + , SiteEnv m ~ site + , Site site + , MonadIO (PersistConfigBackend (SitePersistConfig site) m) + ) + => ExceptT Text (PersistConfigBackend (SitePersistConfig site) m) a + -> ExceptT Text m a +runSiteDBExcept action = do + result <- + lift $ try $ runSiteDB $ either abort return =<< runExceptT action + case result of + Left (FedError t) -> throwE t + Right r -> return r + where + abort = throwIO . FedError + +runDBExcept + :: ( Site site + , MonadIO (PersistConfigBackend (SitePersistConfig site) (HandlerFor site)) + ) + => ExceptT Text (PersistConfigBackend (SitePersistConfig site) (HandlerFor site)) a + -> ExceptT Text (HandlerFor site) a +runDBExcept = runSiteDBExcept + instance MonadSite (HandlerFor site) where type SiteEnv (HandlerFor site) = site askSite = getYesod diff --git a/templates/ticket/dep/list.hamlet b/templates/ticket/dep/list.hamlet deleted file mode 100644 index 2ca2135..0000000 --- a/templates/ticket/dep/list.hamlet +++ /dev/null @@ -1,40 +0,0 @@ -$# This file is part of Vervis. -$# -$# Written in 2016, 2018, 2019, 2020 by fr33domlover . -$# -$# ♡ Copying is an act of love. Please copy, reuse and share. -$# -$# The author(s) have dedicated all copyright and related and neighboring -$# rights to this software to the public domain worldwide. This software is -$# distributed without any warranty. -$# -$# You should have received a copy of the CC0 Public Domain Dedication along -$# with this software. If not, see -$# . - - - - -
Number - Author - Title - Status - $if forward - Remove dependency - $forall (tid, author, title, status) <- rows -
- ### - - ^{sharerLinkFedW author} - - #{title} - - #{show status} - $if forward - - ^{buttonW DELETE "Remove" (TicketDepOldR shr prj ltkhid $ encodeHid tid)} - -$if forward -

- - Add new… diff --git a/templates/ticket/dep/new.hamlet b/templates/ticket/dep/new.hamlet deleted file mode 100644 index 40345dd..0000000 --- a/templates/ticket/dep/new.hamlet +++ /dev/null @@ -1,18 +0,0 @@ -$# This file is part of Vervis. -$# -$# Written in 2016, 2020 by fr33domlover . -$# -$# ♡ Copying is an act of love. Please copy, reuse and share. -$# -$# The author(s) have dedicated all copyright and related and neighboring -$# rights to this software to the public domain worldwide. This software is -$# distributed without any warranty. -$# -$# You should have received a copy of the CC0 Public Domain Dedication along -$# with this software. If not, see -$# . - -

- ^{widget} -
- diff --git a/templates/ticket/one.hamlet b/templates/ticket/one.hamlet index 45e05d1..e541407 100644 --- a/templates/ticket/one.hamlet +++ b/templates/ticket/one.hamlet @@ -37,28 +37,6 @@ $# . ^{followButton} -

- Depended by: - -

    - $if null rdeps -
  • (none) - $else - $forall (E.Value ltid, Entity _ t) <- rdeps -
  • - ^{ticketDepW shar proj ltid t} - -

    - Depends on: - -

      - $if null deps -
    • (none) - $else - $forall (E.Value ltid, Entity _ t) <- deps -
    • - ^{ticketDepW shar proj ltid t} -
      ^{desc} $if ticketStatus ticket /= TSClosed diff --git a/vervis.cabal b/vervis.cabal index 6e783d3..e67ec52 100644 --- a/vervis.cabal +++ b/vervis.cabal @@ -134,6 +134,7 @@ library Vervis.Federation.Offer Vervis.Federation.Push Vervis.Federation.Ticket + Vervis.Federation.Util Vervis.FedURI Vervis.Field.Key Vervis.Field.Person