forge/Vervis
1
0
Fork 0
Code Pull requests Activity

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

Browse source
This commit is contained in:
fr33domlover 2022-09-18 15:55:42 +00:00
parent 9deba96cf2
commit 9906231d04
7 changed files with 161 additions and 23 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

19
migrations/494_2022-09-17_mr_origin.model Normal file
View file

@ -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

65
src/Vervis/Cloth.hs
View file

@ -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

63
src/Vervis/Handler/Cloth.hs
View file

@ -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

2
src/Vervis/Migration.hs
View file

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

3
src/Vervis/Migration/Model.hs
View file

@ -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")

12
src/Web/ActivityPub.hs
View file

@ -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)

20
th/models
View file

@ -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