From 9906231d0469f924b43bcf3cc596702704ef3769 Mon Sep 17 00:00:00 2001
From: fr33domlover <fr33domlover@riseup.net>
Date: Sun, 18 Sep 2022 15:55:42 +0000
Subject: [PATCH] DB, Web: Allow origin repo for Cloths, mention in getClothR
JSON
---
migrations/494_2022-09-17_mr_origin.model | 19 +++++++
src/Vervis/Cloth.hs | 65 +++++++++++++++++++----
src/Vervis/Handler/Cloth.hs | 63 +++++++++++++++++++---
src/Vervis/Migration.hs | 2 +
src/Vervis/Migration/Model.hs | 3 ++
src/Web/ActivityPub.hs | 12 ++---
th/models | 20 +++++++
7 files changed, 161 insertions(+), 23 deletions(-)
create mode 100644 migrations/494_2022-09-17_mr_origin.model
diff --git a/migrations/494_2022-09-17_mr_origin.model b/migrations/494_2022-09-17_mr_origin.model
new file mode 100644
index 0000000..bebc251
--- /dev/null
+++ b/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
diff --git a/src/Vervis/Cloth.hs b/src/Vervis/Cloth.hs
index b385430..0372cff 100644
--- a/src/Vervis/Cloth.hs
+++ b/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
- mne <-
- nonEmpty <$> selectKeysList [BundleTicket ==. tlid] [Desc BundleId]
- case mne of
- Nothing -> error "Found Loom Ticket without any Bundles"
- Just ne -> return ne
+ mergeRequest <- lift $ getMergeRequest tlid
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
diff --git a/src/Vervis/Handler/Cloth.hs b/src/Vervis/Handler/Cloth.hs
index 2433203..649e094 100644
--- a/src/Vervis/Handler/Cloth.hs
+++ b/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
- (Entity _ loom, Entity _ cloth, Entity _ ticket', author', resolve', bundleID' :| _) <-
+ (repoID, mbranch, ticket, author, resolve, proposal) <- runDB $ do
+ (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
diff --git a/src/Vervis/Migration.hs b/src/Vervis/Migration.hs
index a913c29..1b719de 100644
--- a/src/Vervis/Migration.hs
+++ b/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
diff --git a/src/Vervis/Migration/Model.hs b/src/Vervis/Migration/Model.hs
index 47074b6..14ad7ce 100644
--- a/src/Vervis/Migration/Model.hs
+++ b/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")
diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs
index 6db10ee..cc2d9a3 100644
--- a/src/Web/ActivityPub.hs
+++ b/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)
diff --git a/th/models b/th/models
index 25956dc..3ce6b81 100644
--- a/th/models
+++ b/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