C2S: offerTicketC: Support offering a patch to a repo

src/Vervis/API.hs

@@ -84,7 +84,7 @@ import Crypto.PublicVerifKey
 import Database.Persist.JSON
 import Network.FedURI
 import Network.HTTP.Digest
-import Web.ActivityPub hiding (Follow, Ticket)
+import Web.ActivityPub hiding (Patch, Ticket, Follow)
 import Yesod.ActivityPub
 import Yesod.Auth.Unverified
 import Yesod.FedURI
@@ -110,6 +110,7 @@ import Vervis.FedURI
 import Vervis.Foundation
 import Vervis.Model
 import Vervis.Model.Ident
+import Vervis.Model.Repo
 import Vervis.Model.Ticket
 import Vervis.RemoteActorStore
 import Vervis.Settings
@@ -488,8 +489,8 @@ checkFederation remoteRecips = do
     unless (federation || null remoteRecips) $
         throwE "Federation disabled, but remote recipients found"
 
-verifyProjectRecip (Right _)         _           = return ()
+verifyProjectRecipOld (Right _) _ = return ()
-verifyProjectRecip (Left (shr, prj)) localRecips =
+verifyProjectRecipOld (Left (shr, prj)) localRecips =
     fromMaybeE verify "Local context project isn't listed as a recipient"
     where
     verify = do
@@ -497,6 +498,22 @@ verifyProjectRecip (Left (shr, prj)) localRecips =
         projectSet <- lookup prj $ localRecipProjectRelated sharerSet
         guard $ localRecipProject $ localRecipProjectDirect projectSet
 
+verifyProjectRecip (Right _) _ = return ()
+verifyProjectRecip (Left (WTTProject shr prj)) localRecips =
+    fromMaybeE verify "Local context project isn't listed as a recipient"
+    where
+    verify = do
+        sharerSet <- lookup shr localRecips
+        projectSet <- lookup prj $ localRecipProjectRelated sharerSet
+        guard $ localRecipProject $ localRecipProjectDirect projectSet
+verifyProjectRecip (Left (WTTRepo shr rp _ _ _)) localRecips =
+    fromMaybeE verify "Local context repo isn't listed as a recipient"
+    where
+    verify = do
+        sharerSet <- lookup shr localRecips
+        repoSet <- lookup rp $ localRecipRepoRelated sharerSet
+        guard $ localRecipRepo $ localRecipRepoDirect repoSet
+
 -- | Handle a Ticket submitted by a local user to their outbox. The ticket's
 -- context project may be local or remote. Return an error message if the
 -- Ticket is rejected, otherwise the new 'TicketAuthorLocalId'.
@@ -516,7 +533,7 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT
         mrecips <- parseAudience audience
         fromMaybeE mrecips "Create Ticket with no recipients"
     checkFederation remoteRecips
-    verifyProjectRecip context localRecips
+    verifyProjectRecipOld context localRecips
     tracker <- fetchTracker context uTarget
     now <- liftIO getCurrentTime
     (_talid, obiidCreate, docCreate, remotesHttpCreate, maybeAccept) <- runDBExcept $ do
@@ -970,7 +987,7 @@ offerTicketC
     -> ExceptT Text Handler OutboxItemId
 offerTicketC (Entity pidUser personUser) sharerUser summary audience ticket uTarget = do
     let shrUser = sharerIdent sharerUser
-    (title, desc, source, target) <- checkTicket shrUser ticket uTarget
+    (target, title, desc, source) <- checkOfferTicket shrUser ticket uTarget
     ParsedAudience localRecips remoteRecips blinded fwdHosts <- do
         mrecips <- parseAudience audience
         fromMaybeE mrecips "Offer Ticket with no recipients"
@@ -982,18 +999,26 @@ offerTicketC (Entity pidUser personUser) sharerUser summary audience ticket uTar
     (obiidOffer, docOffer, remotesHttpOffer, maybeAccept) <- runDBExcept $ do
         mproject <-
             case target of
-                Left (shr, prj) -> Just <$> do
+                Left (WTTProject shr prj) -> Just . Left <$> do
                     mproj <- lift $ runMaybeT $ do
                         Entity sid s <- MaybeT $ getBy $ UniqueSharer shr
                         ej <- MaybeT $ getBy $ UniqueProject prj sid
                         return (s, ej)
                     fromMaybeE mproj "Offer target no such local project in DB"
+                Left (WTTRepo shr rp mb vcs diff) -> Just . Right <$> do
+                    mproj <- lift $ runMaybeT $ do
+                        Entity sid s <- MaybeT $ getBy $ UniqueSharer shr
+                        er <- MaybeT $ getBy $ UniqueRepo rp sid
+                        return (s, er)
+                    (s, er@(Entity _ r)) <- fromMaybeE mproj "Offer target no such local repo in DB"
+                    unless (repoVcs r == vcs) $ throwE "Patch type and repo VCS mismatch"
+                    return (s, er, mb, diff)
                 Right _ -> return Nothing
         (obiid, doc, luOffer) <- lift $ insertOfferToOutbox shrUser now (personOutbox personUser) blinded
         remotesHttpOffer <- do
             let sieve =
                     case target of
-                        Left (shr, prj) ->
+                        Left (WTTProject shr prj) ->
                             makeRecipientSet
                                 [ LocalActorProject shr prj
                                 ]
@@ -1001,6 +1026,14 @@ offerTicketC (Entity pidUser personUser) sharerUser summary audience ticket uTar
                                 , LocalPersonCollectionProjectTeam shr prj
                                 , LocalPersonCollectionProjectFollowers shr prj
                                 ]
+                        Left (WTTRepo shr rp _ _ _) ->
+                            makeRecipientSet
+                                [ LocalActorRepo shr rp
+                                ]
+                                [ LocalPersonCollectionSharerFollowers shrUser
+                                , LocalPersonCollectionRepoTeam shr rp
+                                , LocalPersonCollectionRepoFollowers shr rp
+                                ]
                         Right _ ->
                             makeRecipientSet
                                 []
@@ -1016,19 +1049,35 @@ offerTicketC (Entity pidUser personUser) sharerUser summary audience ticket uTar
             unless (federation || null moreRemoteRecips) $
                 throwE "Federation disabled, but recipient collection remote members found"
             lift $ deliverRemoteDB'' fwdHosts obiid remoteRecips moreRemoteRecips
-        maccept <- lift $ for mproject $ \ (s, Entity jid j) -> do
+        maccept <- lift $ for mproject $ \ project -> do
-            let shrJ = sharerIdent s
+            let obid =
-                prj = projectIdent j
+                    case project of
-            obiidAccept <- insertEmptyOutboxItem (projectOutbox j) now
+                        Left (_, Entity _ j) -> projectOutbox j
-            ltid <- insertTicket pidUser now title desc source jid obiid obiidAccept
+                        Right (_, Entity _ r, _, _) -> repoOutbox r
-            (docAccept, localRecipsAccept) <- insertAccept shrUser luOffer shrJ prj obiidAccept ltid
+            obiidAccept <- insertEmptyOutboxItem obid now
+            let insertTXL =
+                    case project of
+                        Left (_, Entity jid _) ->
+                            \ tclid -> insert_ $ TicketProjectLocal tclid jid
+                        Right (_, Entity rid _, mb, _) ->
+                            \ tclid -> insert_ $ TicketRepoLocal tclid rid mb
+            (tid, ltid) <- insertTicket pidUser now title desc source insertTXL obiid obiidAccept
+            case project of
+                Left _ -> return ()
+                Right (_, _, _, diff) -> insert_ $ Patch tid now diff
+            (docAccept, localRecipsAccept) <- insertAccept shrUser luOffer project obiidAccept ltid
+            let (actor, ibid) =
+                    case project of
+                        Left (s, Entity _ j) ->
+                            ( LocalActorProject (sharerIdent s) (projectIdent j)
+                            , projectInbox j
+                            )
+                        Right (s, Entity _ r, _, _) ->
+                            ( LocalActorRepo (sharerIdent s) (repoIdent r)
+                            , repoInbox r
+                            )
             knownRemoteRecipsAccept <-
-                deliverLocal'
+                deliverLocal' False actor ibid obiidAccept localRecipsAccept
-                    False
-                    (LocalActorProject shrJ prj)
-                    (projectInbox j)
-                    obiidAccept
-                    localRecipsAccept
             (obiidAccept,docAccept,) <$> deliverRemoteDB'' [] obiidAccept [] knownRemoteRecipsAccept
         return (obiid, doc, remotesHttpOffer, maccept)
     lift $ do
@@ -1037,11 +1086,38 @@ offerTicketC (Entity pidUser personUser) sharerUser summary audience ticket uTar
             forkWorker "offerTicketC: async HTTP Accept delivery" $ deliverRemoteHttp' [] obiidAccept docAccept remotesHttpAccept
     return obiidOffer
     where
+    checkOfferTicket
+        :: ShrIdent
+        -> AP.Ticket URIMode
+        -> FedURI
+        -> ExceptT Text Handler
+            ( Either WorkItemTarget (Host, LocalURI, Maybe (Maybe LocalURI, PatchType, Text))
+            , TextHtml
+            , TextHtml
+            , TextPandocMarkdown
+            )
+    checkOfferTicket shrUser ticket uTarget = do
+        target <- parseTarget uTarget
+        (muContext, summary, content, source, mmr) <- checkTicket shrUser ticket
+        for_ muContext $
+            \ u -> unless (u == uTarget) $ throwE "Offer target != ticket context"
+        target' <- matchTargetAndMR target mmr
+        return (target', summary, content, source)
+        where
+        parseTarget u@(ObjURI h lu) = do
+            hl <- hostIsLocal h
+            if hl
+                then Left <$> do
+                    route <- fromMaybeE (decodeRouteLocal lu) "Offer target is local but not a valid route"
+                    case route of
+                        ProjectR shr prj -> return $ Left (shr, prj)
+                        RepoR shr rp -> return $ Right (shr, rp)
+                        _ -> throwE "Offer target is local but isn't a project/repo route"
+                else return $ Right u
         checkTicket
             shrUser
             (AP.Ticket mlocal attrib mpublished mupdated muContext summary
-         content source muAssigned resolved mmr)
+             content source muAssigned resolved mmr) = do
-        uTarget = do
                 verifyNothingE mlocal "Ticket with 'id'"
                 shrAttrib <- do
                     route <- fromMaybeE (decodeRouteLocal attrib) "Ticket attrib not a valid route"
@@ -1050,26 +1126,84 @@ offerTicketC (Entity pidUser personUser) sharerUser summary audience ticket uTar
                         _ -> throwE "Ticket attrib not a sharer route"
                 unless (shrAttrib == shrUser) $
                     throwE "Ticket attibuted to someone else"
-            verifyNothingE (AP.ticketPublished ticket) "Ticket with 'published'"
+
-            verifyNothingE (AP.ticketUpdated ticket) "Ticket with 'updated'"
+                verifyNothingE mpublished "Ticket with 'published'"
-            for_ muContext $ \ uContext ->
+                verifyNothingE mupdated "Ticket with 'updated'"
-                unless (uContext == uTarget) $ throwE "Offer target != ticket context"
                 verifyNothingE muAssigned "Ticket has 'assignedTo'"
                 when resolved $ throwE "Ticket is resolved"
-            verifyNothingE mmr "Ticket has 'attachment'"
+
-            target <- parseTarget uTarget
+                mmr' <- traverse (uncurry checkMR) mmr
-            return (summary, content, source, target)
+
+                return (muContext, summary, content, source, mmr')
                 where
-        parseTarget u@(ObjURI h lu) = do
+                checkMR h (MergeRequest muOrigin luTarget epatch) = do
+                    verifyNothingE muOrigin "MR with 'origin'"
+                    branch <- checkBranch h luTarget
+                    (typ, content) <-
+                        case epatch of
+                            Left _ -> throwE "MR patch specified as a URI"
+                            Right (hPatch, patch) -> checkPatch hPatch patch
+                    return (branch, typ, content)
+                    where
+                    checkBranch h lu = do
                         hl <- hostIsLocal h
                         if hl
                             then Left <$> do
-                    route <- fromMaybeE (decodeRouteLocal lu) "Offer target is local but not a valid route"
+                                route <-
+                                    fromMaybeE
+                                        (decodeRouteLocal lu)
+                                        "MR target is local but isn't a valid route"
                                 case route of
-                        ProjectR shr prj -> return (shr, prj)
+                                    RepoR shr rp -> return (shr, rp, Nothing)
-                        RepoR _ _ -> throwE "Offering patch to repo not implemented yet"
+                                    RepoBranchR shr rp b -> return (shr, rp, Just b)
-                        _ -> throwE "Offer target is local but isn't a project/repo route"
+                                    _ ->
-                else return $ Right u
+                                        throwE
+                                            "MR target is a valid local route, but isn't a \
+                                            \repo or branch route"
+                            else return $ Right $ ObjURI h lu
+                    checkPatch h (AP.Patch mlocal attrib mpub typ content) = do
+                        verifyNothingE mlocal "Patch with 'id'"
+                        hl <- hostIsLocal h
+                        shrAttrib <- do
+                            route <- fromMaybeE (decodeRouteLocal attrib) "Patch attrib not a valid route"
+                            case route of
+                                SharerR shr -> return shr
+                                _ -> throwE "Patch attrib not a sharer route"
+                        unless (hl && shrAttrib == shrUser) $
+                            throwE "Ticket and Patch attrib mismatch"
+                        verifyNothingE mpub "Patch has 'published'"
+                        return (typ, content)
+        matchTargetAndMR (Left (Left (shr, prj))) Nothing = return $ Left $ WTTProject shr prj
+        matchTargetAndMR (Left (Left (shr, prj))) (Just _) = throwE "Patch offered to project"
+        matchTargetAndMR (Left (Right (shr, rp))) Nothing = throwE "Issue offered to repo"
+        matchTargetAndMR (Left (Right (shr, rp))) (Just (branch, typ, content)) = do
+            branch' <-
+                case branch of
+                    Left (shr', rp', mb) | shr == shr' && rp == rp' -> return mb
+                    _ -> throwE "MR target repo/branch and Offer target repo mismatch"
+            let vcs = typ2vcs typ
+            case vcs of
+                VCSDarcs ->
+                    unless (isNothing branch') $
+                        throwE "Darcs MR specifies a branch"
+                VCSGit ->
+                    unless (isJust branch') $
+                        throwE "Git MR doesn't specify the branch"
+            return $ Left $ WTTRepo shr rp branch' vcs content
+            where
+            typ2vcs PatchTypeDarcs = VCSDarcs
+        matchTargetAndMR (Right (ObjURI h lu)) Nothing = return $ Right (h, lu, Nothing)
+        matchTargetAndMR (Right (ObjURI h lu)) (Just (branch, typ, content)) = do
+            luBranch <-
+                case branch of
+                    Right (ObjURI h' lu') | h == h' -> return lu
+                    _ -> throwE "MR target repo/branch and Offer target repo mismatch"
+            let patch =
+                    ( if lu == luBranch then Nothing else Just luBranch
+                    , typ
+                    , content
+                    )
+            return $ Right (h, lu, Just patch)
     insertOfferToOutbox shrUser now obid blinded = do
         hLocal <- asksSite siteInstanceHost
         obiid <- insertEmptyOutboxItem obid now
@@ -1086,7 +1220,7 @@ offerTicketC (Entity pidUser personUser) sharerUser summary audience ticket uTar
                 }
         update obiid [OutboxItemActivity =. persistJSONObjectFromDoc doc]
         return (obiid, doc, luAct)
-    insertTicket pidAuthor now title desc source jid obiid obiidAccept = do
+    insertTicket pidAuthor now title desc source insertTXL obiid obiidAccept = do
         did <- insert Discussion
         fsid <- insert FollowerSet
         tid <- insert Ticket
@@ -1109,10 +1243,7 @@ offerTicketC (Entity pidUser personUser) sharerUser summary audience ticket uTar
             { ticketContextLocalTicket = tid
             , ticketContextLocalAccept = obiidAccept
             }
-        insert_ TicketProjectLocal
+        insertTXL tclid
-            { ticketProjectLocalContext = tclid
-            , ticketProjectLocalProject = jid
-            }
         talid <- insert TicketAuthorLocal
             { ticketAuthorLocalTicket = ltid
             , ticketAuthorLocalAuthor = pidAuthor
@@ -1122,33 +1253,50 @@ offerTicketC (Entity pidUser personUser) sharerUser summary audience ticket uTar
             { ticketUnderProjectProject = tclid
             , ticketUnderProjectAuthor  = talid
             }
-        return ltid
+        return (tid, ltid)
-    insertAccept shrUser luOffer shrJ prj obiidAccept ltid = do
+    insertAccept shrUser luOffer project obiidAccept ltid = do
+        let (collections, outboxItemRoute, projectRoute, ticketRoute) =
+                case project of
+                    Left (s, Entity _ j) ->
+                        let shr = sharerIdent s
+                            prj = projectIdent j
+                        in  ( [ LocalPersonCollectionProjectTeam shr prj
+                              , LocalPersonCollectionProjectFollowers shr prj
+                              ]
+                            , ProjectOutboxItemR shr prj
+                            , ProjectR shr prj
+                            , ProjectTicketR shr prj
+                            )
+                    Right (s, Entity _ r, _, _) ->
+                        let shr = sharerIdent s
+                            rp = repoIdent r
+                        in  ( [ LocalPersonCollectionRepoTeam shr rp
+                              , LocalPersonCollectionRepoFollowers shr rp
+                              ]
+                            , RepoOutboxItemR shr rp
+                            , RepoR shr rp
+                            , RepoPatchR shr rp
+                            )
         encodeRouteLocal <- getEncodeRouteLocal
         encodeRouteHome <- getEncodeRouteHome
         hLocal <- asksSite siteInstanceHost
         obikhidAccept <- encodeKeyHashid obiidAccept
         ltkhid <- encodeKeyHashid ltid
         let actors = [LocalActorSharer shrUser]
-            collections =
-                [ LocalPersonCollectionProjectTeam shrJ prj
-                , LocalPersonCollectionProjectFollowers shrJ prj
-                ]
             recips =
                 map encodeRouteHome $
                     map renderLocalActor actors ++
                     map renderLocalPersonCollection collections
             doc = Doc hLocal Activity
                 { activityId       =
-                    Just $ encodeRouteLocal $
+                    Just $ encodeRouteLocal $ outboxItemRoute obikhidAccept
-                        ProjectOutboxItemR shrJ prj obikhidAccept
+                , activityActor    = encodeRouteLocal projectRoute
-                , activityActor    = encodeRouteLocal $ ProjectR shrJ prj
                 , activitySummary  = Nothing
                 , activityAudience = Audience recips [] [] [] [] []
                 , activitySpecific = AcceptActivity Accept
                     { acceptObject = ObjURI hLocal luOffer
                     , acceptResult =
-                        Just $ encodeRouteLocal $ ProjectTicketR shrJ prj ltkhid
+                        Just $ encodeRouteLocal $ ticketRoute ltkhid
                     }
                 }
         update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc]

src/Vervis/Federation/Ticket.hs

@@ -90,10 +90,6 @@ import Vervis.Patch
 import Vervis.Ticket
 import Vervis.WorkItem
 
-data WorkItemTarget
-    = WTTProject ShrIdent PrjIdent
-    | WTTRepo ShrIdent RpIdent (Maybe Text) VersionControlSystem Text
-
 checkOfferTicket
     :: RemoteAuthor
     -> AP.Ticket URIMode
@@ -107,14 +103,14 @@ checkOfferTicket
         , TextPandocMarkdown
         )
 checkOfferTicket author ticket uTarget = do
-    target <- checkProject uTarget
+    target <- parseTarget uTarget
     (muContext, summary, content, source, mmr) <- checkTicket ticket
     for_ muContext $
         \ u -> unless (u == uTarget) $ throwE "Offer target != Ticket context"
     target' <- matchTargetAndMR target mmr
     return (target', summary, content, source)
     where
-    checkProject u@(ObjURI h lu) = do
+    parseTarget u@(ObjURI h lu) = do
         hl <- hostIsLocal h
         if hl
             then Left <$> do

src/Vervis/WorkItem.hs

@@ -19,6 +19,7 @@ module Vervis.WorkItem
     , askWorkItemFollowers
     , contextAudience
     , getWorkItemDetail
+    , WorkItemTarget (..)
     )
 where
 
@@ -64,6 +65,7 @@ import Vervis.FedURI
 import Vervis.Foundation
 import Vervis.Model
 import Vervis.Model.Ident
+import Vervis.Model.Repo
 -- import Vervis.Model.Workflow
 -- import Vervis.Paginate
 import Vervis.Patch
@@ -247,3 +249,7 @@ getWorkItemDetail name v = do
                         _ -> throwE "Not a ticket author route"
             else return $ Right u
     mkuri (i, ro) = ObjURI (instanceHost i) (remoteObjectIdent ro)
+
+data WorkItemTarget
+    = WTTProject ShrIdent PrjIdent
+    | WTTRepo ShrIdent RpIdent (Maybe Text) VersionControlSystem Text