DB, Web: Allow origin repo for Cloths, mention in getClothR JSON

migrations/494_2022-09-17_mr_origin.model

@@ -0,0 +1,19 @@
+MergeOriginLocal
+    ticket TicketLoomId
+    repo   RepoId
+    branch Text Maybe
+
+    UniqueMergeOriginLocal ticket
+
+MergeOriginRemote
+    ticket TicketLoomId
+    repo   RemoteActorId
+
+    UniqueMergeOriginRemote ticket
+
+MergeOriginRemoteBranch
+    merge MergeOriginRemoteId
+    ident LocalURI Maybe
+    name  Text
+
+    UniqueMergeOriginRemoteBranch merge

src/Vervis/Cloth.hs

@@ -24,8 +24,10 @@ import Control.Monad.IO.Class
 import Control.Monad.Trans.Class
 import Control.Monad.Trans.Maybe
 import Control.Monad.Trans.Reader
+import Data.Align
 import Data.List.NonEmpty (NonEmpty, nonEmpty)
 import Data.Maybe
+import Data.These
 import Data.Traversable
 import Database.Persist
 import Database.Persist.Sql
@@ -55,7 +57,14 @@ getCloth
                     (Entity TicketResolveLocal)
                     (Entity TicketResolveRemote)
                 )
-            , NonEmpty BundleId
+            , These
+                (NonEmpty BundleId)
+                ( Either
+                    (Entity MergeOriginLocal)
+                    ( Entity MergeOriginRemote
+                    , Maybe (Entity MergeOriginRemoteBranch)
+                    )
+                )
             )
         )
 getCloth lid tlid = runMaybeT $ do
@@ -66,12 +75,7 @@ getCloth lid tlid = runMaybeT $ do
     let tid = ticketLoomTicket tl
     t <- lift $ getJust tid
 
-    bnids <- lift $ do
+    mergeRequest <- lift $ getMergeRequest tlid
-        mne <-
-            nonEmpty <$> selectKeysList [BundleTicket ==. tlid] [Desc BundleId]
-        case mne of
-            Nothing -> error "Found Loom Ticket without any Bundles"
-            Just ne -> return ne
 
     author <-
         lift $
@@ -83,10 +87,46 @@ getCloth lid tlid = runMaybeT $ do
 
     mresolved <- lift $ getResolved tid
 
-    return (Entity lid l, Entity tlid tl, Entity tid t, author, mresolved, bnids)
+    return
+        ( Entity lid l, Entity tlid tl, Entity tid t
+        , author, mresolved, mergeRequest
+        )
 
     where
 
+    getMergeRequest
+        :: MonadIO m
+        => TicketLoomId
+        -> ReaderT SqlBackend m
+            (These
+                (NonEmpty BundleId)
+                ( Either
+                    (Entity MergeOriginLocal)
+                    ( Entity MergeOriginRemote
+                    , Maybe (Entity MergeOriginRemoteBranch)
+                    )
+                )
+            )
+    getMergeRequest tlid = do
+        maybeBundleIDs <-
+            nonEmpty <$> selectKeysList [BundleTicket ==. tlid] [Desc BundleId]
+        maybeOrigin <- do
+            maybeOriginLocal <- getBy $ UniqueMergeOriginLocal tlid
+            maybeOriginRemote <- do
+                mmor <- getBy $ UniqueMergeOriginRemote tlid
+                for mmor $ \ mor@(Entity originID _) ->
+                    (mor,) <$> getBy (UniqueMergeOriginRemoteBranch originID)
+            return $
+                case (maybeOriginLocal, maybeOriginRemote) of
+                    (Nothing, Nothing) -> Nothing
+                    (Just l, Nothing) -> Just $ Left l
+                    (Nothing, Just r) -> Just $ Right r
+                    (Just _, Just _) ->
+                        error "MR has both local and remote origin"
+        case align maybeBundleIDs maybeOrigin of
+            Just mr -> return mr
+            Nothing -> error "MR with neither bundles nor origin"
+
     getResolved
         :: MonadIO m
         => TicketId
@@ -122,7 +162,14 @@ getCloth404
                 (Entity TicketResolveLocal)
                 (Entity TicketResolveRemote)
             )
-        , NonEmpty BundleId
+        , These
+            (NonEmpty BundleId)
+            ( Either
+                (Entity MergeOriginLocal)
+                ( Entity MergeOriginRemote
+                , Maybe (Entity MergeOriginRemoteBranch)
+                )
+            )
         )
 getCloth404 lkhid tlkhid = do
     lid <- decodeKeyHashid404 lkhid

src/Vervis/Handler/Cloth.hs

@@ -66,8 +66,10 @@ import Data.Bifunctor
 import Data.Bitraversable
 import Data.Bool
 import Data.Function
+import Data.Functor
 import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
 import Data.Text (Text)
+import Data.These
 import Data.Traversable
 import Database.Persist
 import Text.Blaze.Html (Html, preEscapedToHtml)
@@ -115,8 +117,8 @@ import Vervis.Widget.Person
 
 getClothR :: KeyHashid Loom -> KeyHashid TicketLoom -> Handler TypedContent
 getClothR loomHash clothHash = do
-    (repoID, mbranch, ticket, author, resolve, bundleID) <- runDB $ do
+    (repoID, mbranch, ticket, author, resolve, proposal) <- runDB $ do
-        (Entity _ loom, Entity _ cloth, Entity _ ticket', author', resolve', bundleID' :| _) <-
+        (Entity _ loom, Entity _ cloth, Entity _ ticket', author', resolve', proposal') <-
             getCloth404 loomHash clothHash
         (,,,,,)
             (loomRepo loom)
@@ -154,16 +156,28 @@ getClothR loomHash clothHash = do
                         )
                         etrx
                 )
-            <*> pure bundleID'
+            <*> bitraverse
+                    (pure . NE.head)
+                    (bitraverse
+                        (pure . entityVal)
+                        (\ (Entity _ (MergeOriginRemote _ r), mbranch) -> do
+                            ra <- getJust r
+                            ro <- getJust $ remoteActorIdent ra
+                            i <- getJust $ remoteObjectInstance ro
+                            return (i, ro, entityVal <$> mbranch)
+                        )
+                    )
+                    proposal'
 
     encodeRouteLocal <- getEncodeRouteLocal
     encodeRouteHome <- getEncodeRouteHome
     hashPerson <- getEncodeKeyHashid
     hashItem <- getEncodeKeyHashid
     hashActor <- getHashLocalActor
+    hashBundle <- getEncodeKeyHashid
+    hashRepo <- getEncodeKeyHashid
     hLocal <- getsYesod siteInstanceHost
     repoHash <- encodeKeyHashid repoID
-    bundleHash <- encodeKeyHashid bundleID
     let route mk = encodeRouteLocal $ mk loomHash clothHash
         authorHost =
             case author of
@@ -179,7 +193,34 @@ getClothR loomHash clothHash = do
             , AP.ticketReverseDeps  = route ClothReverseDepsR
             }
         mergeRequestAP = AP.MergeRequest
-            { AP.mrOrigin = Nothing
+            { AP.mrOrigin = justThere proposal <&> \ origin ->
+                case origin of
+                    Left (MergeOriginLocal _ originRepoID maybeBranch) ->
+                        let luRepo = encodeRouteLocal $ RepoR $ hashRepo originRepoID
+                        in  case maybeBranch of
+                                Nothing -> Left $ ObjURI hLocal luRepo
+                                Just b -> Right
+                                    ( hLocal
+                                    , AP.Branch
+                                        { AP.branchName = b
+                                        , AP.branchRef  = "refs/heads/" <> b
+                                        , AP.branchRepo = luRepo
+                                        }
+                                    )
+                    Right (i, ro, Nothing) ->
+                        Left $ ObjURI (instanceHost i) (remoteObjectIdent ro)
+                    Right (i, ro, Just (MergeOriginRemoteBranch _ mlu b)) ->
+                        let h = instanceHost i
+                        in  case mlu of
+                                Nothing -> Right
+                                    ( h
+                                    , AP.Branch
+                                        { AP.branchName = b
+                                        , AP.branchRef  = "refs/heads/" <> b
+                                        , AP.branchRepo = remoteObjectIdent ro
+                                        }
+                                    )
+                                Just luBranch -> Left $ ObjURI h luBranch
             , AP.mrTarget =
                 case mbranch of
                     Nothing -> Left $ encodeRouteLocal $ RepoR repoHash
@@ -189,7 +230,8 @@ getClothR loomHash clothHash = do
                         , AP.branchRepo = encodeRouteLocal $ RepoR repoHash
                         }
             , AP.mrBundle =
-                Left $ encodeRouteHome $ BundleR loomHash clothHash bundleHash
+                Left . encodeRouteHome . BundleR loomHash clothHash . hashBundle
+                    <$> justHere proposal
             }
         ticketAP = AP.Ticket
             { AP.ticketLocal        = Just (hLocal, ticketLocalAP)
@@ -323,11 +365,15 @@ getBundleR
     -> Handler TypedContent
 getBundleR loomHash clothHash bundleHash = do
     (patchIDs, previousBundles, maybeCurrentBundle) <- runDB $ do
-        (_, Entity clothID _, _, _, _, latest :| prevs) <-
+        (_, Entity clothID _, _, _, _, proposal) <-
             getCloth404 loomHash clothHash
         bundleID <- decodeKeyHashid404 bundleHash
         bundle <- get404 bundleID
         unless (bundleTicket bundle == clothID) notFound
+        latest :| prevs <-
+            case justHere proposal of
+                Nothing -> error "Why didn't getCloth find any bundles"
+                Just bundles -> return bundles
         patches <- do
             ids <- selectKeysList [PatchBundle ==. bundleID] [Desc PatchId]
             case nonEmpty ids of
@@ -376,7 +422,8 @@ getPatchR
     -> Handler TypedContent
 getPatchR loomHash clothHash bundleHash patchHash = do
     (patch, author) <- runDB $ do
-        (_, _, _, author', _, versions) <- getCloth404 loomHash clothHash
+        (_, _, _, author', _, proposal) <- getCloth404 loomHash clothHash
+        let versions = maybe [] NE.toList $ justHere proposal
         (,) <$> do  bundleID <- decodeKeyHashid404 bundleHash
                     unless (bundleID `elem` versions) notFound
                     patchID <- decodeKeyHashid404 patchHash

src/Vervis/Migration.hs

@@ -2688,6 +2688,8 @@ changes hLocal ctx =
     , removeEntity "CollabTopicLocal"
       -- 493
     , addFieldRefOptional "Repo" Nothing "loom" "Loom"
+      -- 494
+    , addEntities model_494_mr_origin
     ]
 
 migrateDB

src/Vervis/Migration/Model.hs

@@ -662,3 +662,6 @@ makeEntitiesMigration "468"
 
 makeEntitiesMigration "486"
     $(modelFile "migrations/486_2022-09-04_collab_enable.model")
+
+model_494_mr_origin :: [Entity SqlBackend]
+model_494_mr_origin = $(schema "494_2022-09-17_mr_origin")

src/Web/ActivityPub.hs

@@ -1109,9 +1109,9 @@ encodeTicketLocal
         <> "dependants"   .= ObjURI a rdeps
 
 data MergeRequest u = MergeRequest
-    { mrOrigin :: Maybe (ObjURI u)
+    { mrOrigin :: Maybe (Either (ObjURI u) (Authority u, Branch u))
     , mrTarget :: Either LocalURI (Branch u)
-    , mrBundle :: Either (ObjURI u) (Authority u, Bundle u)
+    , mrBundle :: Maybe (Either (ObjURI u) (Authority u, Bundle u))
     }
 
 instance ActivityPub MergeRequest where
@@ -1130,17 +1130,17 @@ instance ActivityPub MergeRequest where
 
         fmap (a,) $
             MergeRequest
-                <$> o .:? "origin"
+                <$> (fmap (second fromDoc) <$> o .:+? "origin")
                 <*> pure target'
-                <*> (second fromDoc . toEither <$> o .: "object")
+                <*> (fmap (second fromDoc) <$> o .:+? "object")
         where
         fromDoc (Doc h v) = (h, v)
 
     toSeries h (MergeRequest morigin target bundle)
         =  "type"   .=  ("Offer" :: Text)
-        <> "origin" .=? morigin
+        <> "origin" .=+? fmap (second $ uncurry Doc) morigin
         <> "target" .=+ bimap (ObjURI h) (Doc h) target
-        <> "object" .=  fromEither (second (uncurry Doc) bundle)
+        <> "object" .=+? fmap (second $ uncurry Doc) bundle
 
 data Ticket u = Ticket
     { ticketLocal        :: Maybe (Authority u, TicketLocal)

th/models

@@ -447,6 +447,26 @@ TicketLoom
 
     UniqueTicketLoom ticket
 
+MergeOriginLocal
+    ticket TicketLoomId
+    repo   RepoId
+    branch Text Maybe
+
+    UniqueMergeOriginLocal ticket
+
+MergeOriginRemote
+    ticket TicketLoomId
+    repo   RemoteActorId
+
+    UniqueMergeOriginRemote ticket
+
+MergeOriginRemoteBranch
+    merge MergeOriginRemoteId
+    ident LocalURI Maybe
+    name  Text
+
+    UniqueMergeOriginRemoteBranch merge
+
 TicketAuthorLocal
     ticket TicketId
     author PersonId