diff --git a/src/Vervis/API.hs b/src/Vervis/API.hs index c96a29c..2145e08 100644 --- a/src/Vervis/API.hs +++ b/src/Vervis/API.hs @@ -19,6 +19,7 @@ module Vervis.API , createTicketC , followC , offerTicketC + , offerDepC , undoC , pushCommitsC , getFollowersCollection @@ -114,6 +115,7 @@ import Vervis.RemoteActorStore import Vervis.Settings import Vervis.Patch import Vervis.Ticket +import Vervis.WorkItem parseComment :: LocalURI -> ExceptT Text Handler (ShrIdent, LocalMessageId) parseComment luParent = do @@ -1152,6 +1154,267 @@ offerTicketC (Entity pidUser personUser) sharerUser summary audience ticket uTar update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc] return (doc, makeRecipientSet actors collections) +offerDepC + :: Entity Person + -> Sharer + -> Maybe TextHtml + -> Audience URIMode + -> TicketDependency URIMode + -> FedURI + -> ExceptT Text Handler OutboxItemId +offerDepC (Entity pidUser personUser) sharerUser summary audience dep uTarget = do + let shrUser = sharerIdent sharerUser + (parent, child) <- checkDepAndTarget dep uTarget + ParsedAudience localRecips remoteRecips blinded fwdHosts <- do + mrecips <- parseAudience audience + fromMaybeE mrecips "Offer Ticket with no recipients" + federation <- asksSite $ appFederation . appSettings + unless (federation || null remoteRecips) $ + throwE "Federation disabled, but remote recipients specified" + verifyHosterRecip localRecips "Parent" parent + verifyHosterRecip localRecips "Child" child + now <- liftIO getCurrentTime + parentDetail <- runWorkerExcept $ getWorkItemDetail "Parent" parent + childDetail <- runWorkerExcept $ getWorkItemDetail "Child" child + (obiidOffer, docOffer, remotesHttpOffer, maybeAccept) <- runDBExcept $ do + (obiid, doc, luOffer) <- lift $ insertOfferToOutbox shrUser now (personOutbox personUser) blinded + remotesHttpOffer <- do + wiFollowers <- askWorkItemFollowers + let sieve = + let (parentA, parentC) = + workItemRecipSieve wiFollowers parentDetail + (childA, childC) = + workItemRecipSieve wiFollowers childDetail + in makeRecipientSet + (parentA ++ childA) + (LocalPersonCollectionSharerFollowers shrUser : + parentC ++ childC + ) + moreRemoteRecips <- + lift $ + deliverLocal' + True + (LocalActorSharer shrUser) + (personInbox personUser) + obiid + (localRecipSieve sieve False localRecips) + unless (federation || null moreRemoteRecips) $ + throwE "Federation disabled, but recipient collection remote members found" + lift $ deliverRemoteDB'' fwdHosts obiid remoteRecips moreRemoteRecips + maccept <- + case (widIdent parentDetail, widIdent childDetail) of + (Right _, Left (wi, ltid)) -> do + mhoster <- + lift $ runMaybeT $ + case wi of + WorkItemSharerTicket shr _ _ -> do + sid <- MaybeT $ getKeyBy $ UniqueSharer shr + personInbox <$> + MaybeT (getValBy $ UniquePersonIdent sid) + WorkItemProjectTicket shr prj _ -> do + sid <- MaybeT $ getKeyBy $ UniqueSharer shr + projectInbox <$> + MaybeT (getValBy $ UniqueProject prj sid) + WorkItemRepoPatch shr rp _ -> do + sid <- MaybeT $ getKeyBy $ UniqueSharer shr + repoInbox <$> + MaybeT (getValBy $ UniqueRepo rp sid) + ibidHoster <- fromMaybeE mhoster "Child hoster not in DB" + ibiid <- do + mibil <- lift $ getValBy $ UniqueInboxItemLocal ibidHoster obiid + inboxItemLocalItem <$> + fromMaybeE mibil "Child hoster didn't receive the Offer to their inbox in DB" + lift $ insert_ TicketDependencyOffer + { ticketDependencyOfferOffer = ibiid + , ticketDependencyOfferChild = ltid + } + return Nothing + (Right _, Right _) -> return Nothing + (Left (wi, ltidParent), _) -> Just <$> do + mhoster <- + lift $ runMaybeT $ + case wi of + WorkItemSharerTicket shr _ _ -> do + sid <- MaybeT $ getKeyBy $ UniqueSharer shr + p <- MaybeT (getValBy $ UniquePersonIdent sid) + return (personOutbox p, personInbox p) + WorkItemProjectTicket shr prj _ -> do + sid <- MaybeT $ getKeyBy $ UniqueSharer shr + j <- MaybeT (getValBy $ UniqueProject prj sid) + return (projectOutbox j, projectInbox j) + WorkItemRepoPatch shr rp _ -> do + sid <- MaybeT $ getKeyBy $ UniqueSharer shr + r <- MaybeT (getValBy $ UniqueRepo rp sid) + return (repoOutbox r, repoInbox r) + (obidHoster, ibidHoster) <- fromMaybeE mhoster "Parent hoster not in DB" + obiidAccept <- lift $ insertEmptyOutboxItem obidHoster now + tdid <- lift $ insertDep now pidUser obiid ltidParent (widIdent childDetail) obiidAccept + (docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <- + lift $ insertAccept shrUser wi parentDetail childDetail obiid obiidAccept tdid + knownRemoteRecipsAccept <- + lift $ + deliverLocal' + False + (workItemActor wi) + ibidHoster + obiidAccept + localRecipsAccept + lift $ (obiidAccept,docAccept,fwdHostsAccept,) <$> deliverRemoteDB'' fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept + return (obiid, doc, remotesHttpOffer, maccept) + lift $ do + forkWorker "offerDepC: async HTTP Offer delivery" $ deliverRemoteHttp' fwdHosts obiidOffer docOffer remotesHttpOffer + for_ maybeAccept $ \ (obiidAccept, docAccept, fwdHostsAccept, remotesHttpAccept) -> + forkWorker "offerDepC: async HTTP Accept delivery" $ deliverRemoteHttp' fwdHostsAccept obiidAccept docAccept remotesHttpAccept + return obiidOffer + where + runWorkerExcept action = do + site <- askSite + ExceptT $ liftIO $ runWorker (runExceptT action) site + verifyHosterRecip _ _ (Right _) = return () + verifyHosterRecip localRecips name (Left wi) = + fromMaybeE (verify wi) $ + name <> " ticket hoster actor isn't listed as a recipient" + where + verify (WorkItemSharerTicket shr _ _) = do + sharerSet <- lookup shr localRecips + guard $ localRecipSharer $ localRecipSharerDirect sharerSet + verify (WorkItemProjectTicket shr prj _) = do + sharerSet <- lookup shr localRecips + projectSet <- lookup prj $ localRecipProjectRelated sharerSet + guard $ localRecipProject $ localRecipProjectDirect projectSet + verify (WorkItemRepoPatch shr rp _) = do + sharerSet <- lookup shr localRecips + repoSet <- lookup rp $ localRecipRepoRelated sharerSet + guard $ localRecipRepo $ localRecipRepoDirect repoSet + insertOfferToOutbox shrUser now obid blinded = do + hLocal <- asksSite siteInstanceHost + obiid <- insertEmptyOutboxItem obid now + encodeRouteLocal <- getEncodeRouteLocal + obikhid <- encodeKeyHashid obiid + let luAct = encodeRouteLocal $ SharerOutboxItemR shrUser obikhid + doc = Doc hLocal Activity + { activityId = Just luAct + , activityActor = encodeRouteLocal $ SharerR shrUser + , activitySummary = summary + , activityAudience = blinded + , activitySpecific = + OfferActivity $ Offer (OfferDep dep) uTarget + } + update obiid [OutboxItemActivity =. persistJSONObjectFromDoc doc] + return (obiid, doc, luAct) + workItemRecipSieve wiFollowers (WorkItemDetail ident context author) = + let authorC = + case author of + Left shr -> [LocalPersonCollectionSharerFollowers shr] + Right _ -> [] + ticketC = + case ident of + Left (wi, _) -> [wiFollowers wi] + Right _ -> [] + (contextA, contextC) = + case context of + Left local -> + case local of + Left (shr, prj) -> + ( [LocalActorProject shr prj] + , [ LocalPersonCollectionProjectTeam shr prj + , LocalPersonCollectionProjectFollowers shr prj + ] + ) + Right (shr, rp) -> + ( [LocalActorRepo shr rp] + , [ LocalPersonCollectionRepoTeam shr rp + , LocalPersonCollectionRepoFollowers shr rp + ] + ) + Right _ -> ([], []) + in (contextA, authorC ++ ticketC ++ contextC) + insertDep now pidAuthor obiidOffer 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_ TicketDependencyAuthorLocal + { ticketDependencyAuthorLocalDep = tdid + , ticketDependencyAuthorLocalAuthor = pidAuthor + , ticketDependencyAuthorLocalOpen = obiidOffer + } + return tdid + workItemActor (WorkItemSharerTicket shr _ _) = LocalActorSharer shr + workItemActor (WorkItemProjectTicket shr prj _) = LocalActorProject shr prj + workItemActor (WorkItemRepoPatch shr rp _) = LocalActorRepo shr rp + insertAccept shrUser wiParent (WorkItemDetail _ parentCtx parentAuthor) (WorkItemDetail childId childCtx childAuthor) obiidOffer obiidAccept tdid = do + encodeRouteLocal <- getEncodeRouteLocal + encodeRouteHome <- getEncodeRouteHome + wiFollowers <- askWorkItemFollowers + hLocal <- asksSite siteInstanceHost + + obikhidOffer <- encodeKeyHashid obiidOffer + obikhidAccept <- encodeKeyHashid obiidAccept + tdkhid <- encodeKeyHashid tdid + + let audAuthor = + AudLocal + [LocalActorSharer shrUser] + [LocalPersonCollectionSharerFollowers shrUser] + audParentContext = contextAudience parentCtx + audChildContext = contextAudience childCtx + audParentAuthor = authorAudience parentAuthor + audParentFollowers = AudLocal [] [wiFollowers wiParent] + audChildAuthor = authorAudience childAuthor + audChildFollowers = + case childId of + Left (wi, _ltid) -> AudLocal [] [wiFollowers wi] + Right (ObjURI h _, luFollowers) -> AudRemote h [] [luFollowers] + + (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = + collectAudience $ + audAuthor : + audParentAuthor : + audParentFollowers : + audChildAuthor : + audChildFollowers : + audParentContext ++ audChildContext + + actor = workItemActor wiParent + recips = map encodeRouteHome audLocal ++ audRemote + doc = Doc hLocal Activity + { activityId = + Just $ encodeRouteLocal $ + actorOutboxItem actor obikhidAccept + , activityActor = encodeRouteLocal $ renderLocalActor actor + , activitySummary = Nothing + , activityAudience = Audience recips [] [] [] [] [] + , activitySpecific = AcceptActivity Accept + { acceptObject = + encodeRouteHome $ SharerOutboxItemR shrUser obikhidOffer + , acceptResult = + Just $ encodeRouteLocal $ TicketDepR tdkhid + } + } + + update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc] + return (doc, recipientSet, remoteActors, fwdHosts) + where + authorAudience (Left shr) = AudLocal [LocalActorSharer shr] [] + authorAudience (Right (ObjURI h lu)) = AudRemote h [lu] [] + actorOutboxItem (LocalActorSharer shr) = SharerOutboxItemR shr + actorOutboxItem (LocalActorProject shr prj) = ProjectOutboxItemR shr prj + actorOutboxItem (LocalActorRepo shr rp) = RepoOutboxItemR shr rp + undoC :: ShrIdent -> Maybe TextHtml diff --git a/src/Vervis/Federation/Ticket.hs b/src/Vervis/Federation/Ticket.hs index 49b1fdd..b38a3de 100644 --- a/src/Vervis/Federation/Ticket.hs +++ b/src/Vervis/Federation/Ticket.hs @@ -85,6 +85,7 @@ import Vervis.Model.Ident import Vervis.Model.Ticket import Vervis.Patch import Vervis.Ticket +import Vervis.WorkItem checkOffer :: AP.Ticket URIMode @@ -954,147 +955,6 @@ sharerOfferDepF now shrRecip author body mfwd luOffer dep uTarget = do else LocalPersonCollectionSharerTicketFollowers in coll shrRecip (hashTALID talid) -data WorkItemDetail = WorkItemDetail - { widIdent :: Either (WorkItem, LocalTicketId) (FedURI, LocalURI) - , widContext :: Either (Either (ShrIdent, PrjIdent) (ShrIdent, RpIdent)) (FedURI, Host, Maybe LocalURI, Maybe LocalURI) - , widAuthor :: Either ShrIdent FedURI - } - -getAuthor - :: MonadIO m - => Either - (Entity TicketAuthorLocal, Entity TicketUnderProject) - (Entity TicketAuthorRemote) - -> ReaderT SqlBackend m (Either ShrIdent (Instance, RemoteObject)) -getAuthor = - 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) - ) - -getWorkItemDetail - :: Text -> Either WorkItem FedURI -> ExceptT Text Worker WorkItemDetail -getWorkItemDetail name v = do - manager <- asksSite appHttpManager - (childId, childCtx, childAuthor) <- - case v of - Left wi -> runSiteDBExcept $ do - (ltid, ctx, author) <- getWorkItem name 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) $ name <> ": 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 $ name <> ": 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 $ WorkItemDetail childId childCtx' childAuthor - where - 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 $ getAuthor 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 $ getAuthor author - return (ltid, Left $ Right (sharerIdent s, repoIdent r), author') - 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 - mkuri (i, ro) = ObjURI (instanceHost i) (remoteObjectIdent ro) insertDep @@ -1131,42 +991,6 @@ insertDep now author ractidOffer ltidParent child obiidAccept = do } return tdid -askWorkItemFollowers - :: (MonadSite m, YesodHashids (SiteEnv m)) - => m (WorkItem -> LocalPersonCollection) -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 - -contextAudience - :: Either - (Either (ShrIdent, PrjIdent) (ShrIdent, RpIdent)) - (FedURI, Host, Maybe LocalURI, Maybe LocalURI) - -> [Aud URIMode] -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]) - ] - projectOfferDepF :: UTCTime -> ShrIdent @@ -1190,7 +1014,7 @@ projectOfferDepF now shrRecip prjRecip author body mfwd luOffer dep uTarget = do (_, _, _, _, _, _, author) <- do mticket <- lift $ getProjectTicket shrRecip prjRecip parentLtid fromMaybeE mticket $ "Parent" <> ": No such project-ticket" - lift $ getAuthor author + lift $ getWorkItemAuthorDetail author childDetail <- getWorkItemDetail "Child" child return (parentLtid, parentAuthor, childDetail) mhttp <- runSiteDBExcept $ do @@ -1351,7 +1175,7 @@ repoOfferDepF now shrRecip rpRecip author body mfwd luOffer dep uTarget = do (_, _, _, _, _, _, author, _) <- do mticket <- lift $ getRepoPatch shrRecip rpRecip parentLtid fromMaybeE mticket $ "Parent" <> ": No such repo-patch" - lift $ getAuthor author + lift $ getWorkItemAuthorDetail author childDetail <- getWorkItemDetail "Child" child return (parentLtid, parentAuthor, childDetail) mhttp <- runSiteDBExcept $ do diff --git a/src/Vervis/Handler/Client.hs b/src/Vervis/Handler/Client.hs index 2c784c5..ae967e2 100644 --- a/src/Vervis/Handler/Client.hs +++ b/src/Vervis/Handler/Client.hs @@ -302,6 +302,8 @@ postSharerOutboxR shr = do case obj of OfferTicket ticket -> offerTicketC eperson sharer summary audience ticket target + OfferDep dep -> + offerDepC eperson sharer summary audience dep target _ -> throwE "Unsupported Offer 'object' type" UndoActivity undo -> undoC shr summary audience undo diff --git a/src/Vervis/WorkItem.hs b/src/Vervis/WorkItem.hs new file mode 100644 index 0000000..cbe329b --- /dev/null +++ b/src/Vervis/WorkItem.hs @@ -0,0 +1,249 @@ +{- This file is part of Vervis. + - + - Written in 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.WorkItem + ( WorkItemDetail (..) + , getWorkItemAuthorDetail + , askWorkItemFollowers + , contextAudience + , getWorkItemDetail + ) +where + +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.Bifunctor +import Data.Bitraversable +-- import Data.Either +-- import Data.Foldable (for_) +import Data.Maybe +import Data.Text (Text) +-- import Data.Traversable +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 Data.Text as T + +import Network.FedURI +import Web.ActivityPub +import Yesod.ActivityPub +import Yesod.FedURI +import Yesod.Hashids +import Yesod.MonadSite + +import qualified Web.ActivityPub as AP + +import Control.Monad.Trans.Except.Local +-- import Data.Either.Local +-- import Data.Paginate.Local +-- import Database.Persist.Local +-- import Yesod.Persist.Local + +import Vervis.ActivityPub.Recipient +import Vervis.FedURI +import Vervis.Foundation +import Vervis.Model +import Vervis.Model.Ident +-- import Vervis.Model.Workflow +-- import Vervis.Paginate +import Vervis.Patch +import Vervis.Ticket +-- import Vervis.Widget.Ticket (TicketSummary (..)) + +data WorkItemDetail = WorkItemDetail + { widIdent :: Either (WorkItem, LocalTicketId) (FedURI, LocalURI) + , widContext :: Either (Either (ShrIdent, PrjIdent) (ShrIdent, RpIdent)) (FedURI, Host, Maybe LocalURI, Maybe LocalURI) + , widAuthor :: Either ShrIdent FedURI + } + +getWorkItemAuthorDetail + :: MonadIO m + => Either + (Entity TicketAuthorLocal, Entity TicketUnderProject) + (Entity TicketAuthorRemote) + -> ReaderT SqlBackend m (Either ShrIdent (Instance, RemoteObject)) +getWorkItemAuthorDetail = + 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) + ) + +askWorkItemFollowers + :: (MonadSite m, YesodHashids (SiteEnv m)) + => m (WorkItem -> LocalPersonCollection) +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 + +contextAudience + :: Either + (Either (ShrIdent, PrjIdent) (ShrIdent, RpIdent)) + (FedURI, Host, Maybe LocalURI, Maybe LocalURI) + -> [Aud URIMode] +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]) + ] + +getWorkItemDetail + :: Text -> Either WorkItem FedURI -> ExceptT Text Worker WorkItemDetail +getWorkItemDetail name v = do + manager <- asksSite appHttpManager + (childId, childCtx, childAuthor) <- + case v of + Left wi -> runSiteDBExcept $ do + (ltid, ctx, author) <- getWorkItem name 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) $ name <> ": 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 $ name <> ": 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 $ WorkItemDetail childId childCtx' childAuthor + where + 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 $ getWorkItemAuthorDetail 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 $ getWorkItemAuthorDetail author + return (ltid, Left $ Right (sharerIdent s, repoIdent r), author') + 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 + mkuri (i, ro) = ObjURI (instanceHost i) (remoteObjectIdent ro) diff --git a/vervis.cabal b/vervis.cabal index e67ec52..19ff77b 100644 --- a/vervis.cabal +++ b/vervis.cabal @@ -216,6 +216,7 @@ library Vervis.Widget.Ticket Vervis.Widget.Workflow Vervis.Wiki + Vervis.WorkItem -- other-modules: default-extensions: TemplateHaskell QuasiQuotes