From 9906231d0469f924b43bcf3cc596702704ef3769 Mon Sep 17 00:00:00 2001 From: fr33domlover 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