C2S: Implement offerDepC, allowing to create ticket dependencies

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

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

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

src/Vervis/WorkItem.hs

@@ -0,0 +1,249 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2020 by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ 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
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+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)

vervis.cabal

@@ -216,6 +216,7 @@ library
                        Vervis.Widget.Ticket
                        Vervis.Widget.Workflow
                        Vervis.Wiki
+                       Vervis.WorkItem
   -- other-modules:       
   default-extensions:  TemplateHaskell
                        QuasiQuotes