S2S: Loom: Port Offer{MR} handler from old federation code
This is to allow getting rid of the old C2S offerTicketC and write a C2S Offer handler in the new actor system. And that is to allow ticket opening and closing to work, so that it can use delegated OCAPs too, as a first demo of delegated OCAPs in action.
This commit is contained in:
Pere Lev
parent
909ba94b49
commit
a06003c361
7 changed files with 444 additions and 351 deletions
|
|
@ -18,7 +18,7 @@
|
|||
|
||||
module Vervis.API
|
||||
( handleViaActor
|
||||
, acceptC
|
||||
--, acceptC
|
||||
--, addBundleC
|
||||
, applyC
|
||||
--, noteC
|
||||
|
|
@ -188,6 +188,7 @@ verifyRemoteAddressed remoteRecips u =
|
|||
lus <- lookup h remoteRecips
|
||||
guard $ lu `elem` lus
|
||||
|
||||
{-
|
||||
acceptC
|
||||
:: Entity Person
|
||||
-> Actor
|
||||
|
|
@ -203,8 +204,6 @@ acceptC
|
|||
-> AP.Accept URIMode
|
||||
-> ExceptT Text Handler OutboxItemId
|
||||
acceptC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips remoteRecips fwdHosts action accept = do
|
||||
error "acceptC temporarily disabled due to actor refactoring"
|
||||
{-
|
||||
-- Check input
|
||||
verifyNothingE maybeCap "Capability not needed"
|
||||
acceptee <- parseAccept accept
|
||||
|
|
@ -1922,7 +1921,7 @@ offerTicketC (Entity senderPersonID senderPerson) senderActor maybeCap localReci
|
|||
lift $ forkWorker "offerTicketC: async HTTP Offer delivery" deliverHttpOffer
|
||||
for_ maybeAcceptMaybePull $ \ (deliverHttpAccept, maybePull) -> do
|
||||
lift $ forkWorker "offerTicketC: async HTTP Accept delivery" deliverHttpAccept
|
||||
traverse generatePatches maybePull
|
||||
VA2.runActE $ traverse generatePatches maybePull
|
||||
|
||||
return offerID
|
||||
|
||||
|
|
|
|||
|
|
@ -18,23 +18,40 @@ module Vervis.Actor.Loom
|
|||
)
|
||||
where
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Exception.Base
|
||||
import Control.Monad
|
||||
import Control.Monad.IO.Class
|
||||
import Control.Monad.Logger.CallStack
|
||||
import Control.Monad.Trans.Class
|
||||
import Control.Monad.Trans.Except
|
||||
import Control.Monad.Trans.Maybe
|
||||
import Control.Monad.Trans.Reader
|
||||
import Data.Align
|
||||
import Data.Bifunctor
|
||||
import Data.Bitraversable
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.Foldable
|
||||
import Data.List.NonEmpty (NonEmpty (..))
|
||||
import Data.Maybe
|
||||
import Data.Text (Text)
|
||||
import Data.These
|
||||
import Data.Time.Clock
|
||||
import Data.Traversable
|
||||
import Database.Persist
|
||||
import Database.Persist.Sql
|
||||
import Optics.Core
|
||||
import Yesod.Persist.Core
|
||||
|
||||
import qualified Data.List.NonEmpty as NE
|
||||
import qualified Data.Text as T
|
||||
import qualified Database.Esqueleto as E
|
||||
|
||||
import Control.Concurrent.Actor
|
||||
import Development.PatchMediaType
|
||||
import Network.FedURI
|
||||
import Web.Actor
|
||||
import Web.Actor.Persist
|
||||
import Yesod.MonadSite
|
||||
|
||||
import qualified Web.ActivityPub as AP
|
||||
|
|
@ -42,19 +59,360 @@ import qualified Web.ActivityPub as AP
|
|||
import Control.Monad.Trans.Except.Local
|
||||
import Database.Persist.Local
|
||||
|
||||
import Vervis.Access
|
||||
import Vervis.ActivityPub
|
||||
import Vervis.Actor
|
||||
import Vervis.Actor.Common
|
||||
import Vervis.Actor2
|
||||
import Vervis.Cloth
|
||||
import Vervis.Data.Actor
|
||||
import Vervis.Data.Collab
|
||||
import Vervis.Data.Discussion
|
||||
import Vervis.Data.Ticket
|
||||
import Vervis.FedURI
|
||||
import Vervis.Federation.Util
|
||||
import Vervis.Fetch
|
||||
import Vervis.Foundation
|
||||
import Vervis.Model
|
||||
import Vervis.Model hiding (deckCreate)
|
||||
import Vervis.Recipient (makeRecipientSet, LocalStageBy (..), Aud (..), collectAudience, localActorFollowers)
|
||||
import Vervis.Persist.Actor
|
||||
import Vervis.Persist.Collab
|
||||
import Vervis.Persist.Discussion
|
||||
import Vervis.RemoteActorStore
|
||||
import Vervis.Ticket
|
||||
import Vervis.Web.Repo
|
||||
|
||||
-- Meaning: An actor A is offering a ticket or a ticket dependency
|
||||
-- Behavior:
|
||||
-- * Verify I'm the target
|
||||
-- * Insert the Offer to my inbox
|
||||
-- * Create the new ticket in my DB
|
||||
-- * Forward the Offer to my followers
|
||||
-- * Publish an Accept to:
|
||||
-- - My followers
|
||||
-- - Offer sender+followers
|
||||
loomOffer
|
||||
:: UTCTime
|
||||
-> LoomId
|
||||
-> Verse
|
||||
-> AP.Offer URIMode
|
||||
-> ActE (Text, Act (), Next)
|
||||
loomOffer now loomID (Verse authorIdMsig body) (AP.Offer object uTarget) = do
|
||||
|
||||
-- Check input
|
||||
(title, desc, source, originTipOrBundle, targetRepoID, maybeTargetBranch) <- do
|
||||
ticket <-
|
||||
case object of
|
||||
AP.OfferTicket t -> pure t
|
||||
_ -> throwE "Unsupported Offer.object type"
|
||||
ObjURI hAuthor _ <- lift $ getActorURI authorIdMsig
|
||||
let author = bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig
|
||||
WorkItemOffer {..} <- checkOfferTicket hAuthor ticket uTarget
|
||||
unless (bimap LocalActorPerson id wioAuthor == author) $
|
||||
throwE "Offering a Ticket attributed to someone else"
|
||||
Merge maybeOriginTip maybeBundle targetTip <- case wioRest of
|
||||
TAM_Task _ ->
|
||||
throwE
|
||||
"Offer target is some local deck, so I have no use for \
|
||||
\this Offer. Was I supposed to receive it?"
|
||||
TAM_Merge loomID' merge ->
|
||||
if loomID' == loomID
|
||||
then return merge
|
||||
else throwE
|
||||
"Offer target is some other local loom, so I have \
|
||||
\no use for this Offer. Was I supposed to receive \
|
||||
\it?"
|
||||
TAM_Remote _ _ ->
|
||||
throwE
|
||||
"Offer target is some remote tracker, so I have no use \
|
||||
\for this Offer. Was I supposed to receive it?"
|
||||
originTipOrBundle <-
|
||||
fromMaybeE
|
||||
(align maybeOriginTip maybeBundle)
|
||||
"MR provides neither origin nor patches"
|
||||
(targetRepoID, maybeTargetBranch) <-
|
||||
case targetTip of
|
||||
TipLocalRepo repoID -> pure (repoID, Nothing)
|
||||
TipLocalBranch repoID branch -> pure (repoID, Just branch)
|
||||
_ -> throwE "MR target is a remote repo (this tracker serves only local repos)"
|
||||
return (wioTitle, wioDesc, wioSource, originTipOrBundle, targetRepoID, maybeTargetBranch)
|
||||
|
||||
-- Verify the capability URI, if provided, is one of:
|
||||
-- * Outbox item URI of a local actor, i.e. a local activity
|
||||
-- * A remote URI
|
||||
maybeCapability <-
|
||||
for (AP.activityCapability $ actbActivity body) $ \ uCap ->
|
||||
nameExceptT "Offer.capability" $
|
||||
first (\ (actor, _, item) -> (actor, item)) <$>
|
||||
parseActivityURI' uCap
|
||||
|
||||
-- If origin repo is remote, HTTP GET its AP representation and
|
||||
-- remember it in our DB
|
||||
--
|
||||
-- Why do we need to HTTP GET it? Because:
|
||||
-- * No support for providing a signed repo object directly in the
|
||||
-- Offer activity
|
||||
-- * It may be nice to make sure a remote origin repo's VCS type
|
||||
-- matches the target repo's VCS, even if patches are provided too
|
||||
-- + However there's no support for caching VCS type when
|
||||
-- remembering remote repo in our DB, so we'd have to check this
|
||||
-- every time
|
||||
-- * If origin is remote and no patches are provided, we'll need to
|
||||
-- know the clone URL to generate the patches ourselves
|
||||
-- + However the code here, for some simplicity, doesn't have a
|
||||
-- way to skip that and do the whole handler synchronously in
|
||||
-- case patches are provided or the origin is a local repo
|
||||
-- + And no support for caching the clone URI in DB when
|
||||
-- remembering the remote repo, so we'd need to do this every
|
||||
-- time
|
||||
let originTipOrBundle' =
|
||||
bimap
|
||||
(\case
|
||||
TipLocalRepo repoID -> Left (repoID, Nothing)
|
||||
TipLocalBranch repoID branch -> Left (repoID, Just branch)
|
||||
TipRemote uOrigin -> Right (uOrigin, Nothing)
|
||||
TipRemoteBranch uRepo branch -> Right (uRepo, Just branch)
|
||||
)
|
||||
id
|
||||
originTipOrBundle
|
||||
originTipOrBundle'' <-
|
||||
bitraverse
|
||||
(bitraverse
|
||||
pure
|
||||
(\ (uOrigin, maybeOriginBranch) -> do
|
||||
case maybeOriginBranch of
|
||||
Nothing -> do
|
||||
(vcs, raid, uClone, mb) <- withExceptT (T.pack . show) $ httpGetRemoteTip' uOrigin
|
||||
return (vcs, (raid, uClone, first Just <$> mb))
|
||||
Just branch -> do
|
||||
(vcs, raid, uClone) <- withExceptT (T.pack . show) $ httpGetRemoteRepo' uOrigin
|
||||
return (vcs, (raid, uClone, Just (Nothing, branch)))
|
||||
)
|
||||
)
|
||||
pure
|
||||
originTipOrBundle'
|
||||
|
||||
maybeNew <- withDBExcept $ do
|
||||
|
||||
-- Grab me from DB
|
||||
(loomRecip, actorRecip) <- lift $ do
|
||||
d <- getJust loomID
|
||||
(d,) <$> getJust (loomActor d)
|
||||
|
||||
-- Grab loom's repo from DB and verify that it consents to be served by
|
||||
-- the loom, otherwise this loom doesn't accept tickets
|
||||
let recipLoomRepoID = loomRepo loomRecip
|
||||
unless (targetRepoID == recipLoomRepoID) $
|
||||
throwE "MR target repo isn't the one served by the Offer target loom"
|
||||
targetRepo <- lift $ getJust targetRepoID
|
||||
unless (repoLoom targetRepo == Just loomID) $
|
||||
throwE "Offer target loom doesn't have repo's consent to serve it"
|
||||
|
||||
-- Verify VCS type match between patch bundle and target repo
|
||||
let targetRepoVCS = repoVcs targetRepo
|
||||
for_ (justThere originTipOrBundle) $ \ (Material typ diffs) -> do
|
||||
unless (targetRepoVCS == patchMediaTypeVCS typ) $
|
||||
throwE "Patch type and local target repo VCS mismatch"
|
||||
case (typ, diffs) of
|
||||
(PatchMediaTypeDarcs, _ :| _ : _) ->
|
||||
throwE "More than one Darcs dpatch file provided"
|
||||
_ -> pure ()
|
||||
|
||||
-- If origin repo is local, find it in our DB.
|
||||
--
|
||||
-- Verify the (local or remote) origin repo's VCS type matches the
|
||||
-- target repo.
|
||||
originOrBundle' <-
|
||||
bitraverse
|
||||
(bitraverse
|
||||
(\ origin@(repoID, maybeBranch) -> do
|
||||
repo <- getE repoID "MR origin local repo not found in DB"
|
||||
unless (repoVcs repo == targetRepoVCS) $
|
||||
throwE "Local origin repo VCS differs from target repo VCS"
|
||||
return origin
|
||||
)
|
||||
(\ (vcs, origin) -> do
|
||||
unless (vcs == targetRepoVCS) $
|
||||
throwE "Remote origin repo VCS differs from target repo VCS"
|
||||
return origin
|
||||
)
|
||||
)
|
||||
pure
|
||||
originTipOrBundle''
|
||||
|
||||
-- Verify that branches are specified for Git and aren't specified for
|
||||
-- Darcs
|
||||
-- Also, produce a data structure separating by VCS rather than by
|
||||
-- local/remote origin, which we'll need for generating patches
|
||||
tipInfo <- case targetRepoVCS of
|
||||
VCSGit -> do
|
||||
targetBranch <- fromMaybeE maybeTargetBranch "Local target repo is Git but no target branch specified"
|
||||
maybeOrigin <- for (justHere originOrBundle') $ \case
|
||||
Left (originRepoID, maybeOriginBranch) -> do
|
||||
originBranch <- fromMaybeE maybeOriginBranch "Local origin repo is Git but no origin branch specified"
|
||||
return (Left originRepoID, originBranch)
|
||||
Right (_remoteActorID, uClone, maybeOriginBranch) -> do
|
||||
(_maybeURI, originBranch) <- fromMaybeE maybeOriginBranch "Remote origin repo is Git but no origin branch specified"
|
||||
return (Right uClone, originBranch)
|
||||
return $ Left (targetBranch, maybeOrigin)
|
||||
VCSDarcs -> do
|
||||
verifyNothingE maybeTargetBranch "Local target repo is Darcs but target branch specified"
|
||||
maybeOriginRepo <- for (justHere originOrBundle') $ \case
|
||||
Left (originRepoID, maybeOriginBranch) -> do
|
||||
verifyNothingE maybeOriginBranch "Local origin repo is Darcs but origin branch specified"
|
||||
return $ Left originRepoID
|
||||
Right (_remoteActorID, uClone, maybeOriginBranch) -> do
|
||||
verifyNothingE maybeOriginBranch "Remote origin repo is Darcs but origin branch specified"
|
||||
return $ Right uClone
|
||||
return $ Right $ maybeOriginRepo
|
||||
|
||||
-- Insert the Offer to my inbox
|
||||
mractid <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) False
|
||||
for mractid $ \ offerDB -> do
|
||||
|
||||
-- If a capability is provided, check it
|
||||
for_ maybeCapability $ \ cap -> do
|
||||
lcap <-
|
||||
case cap of
|
||||
Left c -> pure c
|
||||
Right _ -> throwE "Capability is a remote URI, i.e. not authored by me"
|
||||
verifyCapability'
|
||||
lcap
|
||||
authorIdMsig
|
||||
(GrantResourceLoom loomID)
|
||||
AP.RoleReport
|
||||
|
||||
-- Prepare forwarding the Offer to my followers
|
||||
let recipByID = grantResourceLocalActor $ GrantResourceLoom loomID
|
||||
recipByHash <- hashLocalActor recipByID
|
||||
let sieve = makeRecipientSet [] [localActorFollowers recipByHash]
|
||||
|
||||
-- Insert the new ticket to our DB
|
||||
acceptID <- lift $ insertEmptyOutboxItem' (actorOutbox actorRecip) now
|
||||
offerDB' <-
|
||||
bitraverse
|
||||
(traverseOf _1 $ \case
|
||||
LocalActorPerson personID -> pure personID
|
||||
_ -> throwE "Local non-Person ticket authors not allowed"
|
||||
)
|
||||
pure
|
||||
offerDB
|
||||
ticketID <- lift $ insertTask title desc source offerDB' acceptID
|
||||
clothID <- lift $ insertMerge loomID ticketID maybeTargetBranch originOrBundle'
|
||||
let maybePull =
|
||||
let maybeTipInfo =
|
||||
case tipInfo of
|
||||
Left (b, mo) -> Left . (b,) <$> mo
|
||||
Right mo -> Right <$> mo
|
||||
hasBundle = isJust $ justThere originOrBundle'
|
||||
in (clothID, targetRepoID, hasBundle,) <$> maybeTipInfo
|
||||
|
||||
-- Prepare an Accept activity and insert to my outbox
|
||||
accept@(actionAccept, _, _, _) <- lift $ prepareAccept clothID
|
||||
let recipByKey = LocalActorLoom loomID
|
||||
_luAccept <- lift $ updateOutboxItem' recipByKey acceptID actionAccept
|
||||
|
||||
return (loomActor loomRecip, sieve, acceptID, accept, maybePull)
|
||||
|
||||
case maybeNew of
|
||||
Nothing -> done "I already have this activity in my inbox"
|
||||
Just (loomActorID, sieve, acceptID, (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept), maybePull) -> do
|
||||
traverse_ generatePatches maybePull
|
||||
forwardActivity
|
||||
authorIdMsig body (LocalActorLoom loomID) loomActorID sieve
|
||||
lift $ sendActivity
|
||||
(LocalActorLoom loomID) loomActorID localRecipsAccept
|
||||
remoteRecipsAccept fwdHostsAccept acceptID actionAccept
|
||||
done "Opened a MR and forwarded the Offer"
|
||||
|
||||
where
|
||||
|
||||
insertTask title desc source offerDB acceptID = do
|
||||
did <- insert Discussion
|
||||
fsid <- insert FollowerSet
|
||||
tid <- insert Ticket
|
||||
{ ticketNumber = Nothing
|
||||
, ticketCreated = now
|
||||
, ticketTitle = title
|
||||
, ticketSource = source
|
||||
, ticketDescription = desc
|
||||
, ticketDiscuss = did
|
||||
, ticketFollowers = fsid
|
||||
, ticketAccept = acceptID
|
||||
}
|
||||
case offerDB of
|
||||
Left (personID, _, offerID) ->
|
||||
insert_ TicketAuthorLocal
|
||||
{ ticketAuthorLocalTicket = tid
|
||||
, ticketAuthorLocalAuthor = personID
|
||||
, ticketAuthorLocalOpen = offerID
|
||||
}
|
||||
Right (author, _, offerID) ->
|
||||
insert_ TicketAuthorRemote
|
||||
{ ticketAuthorRemoteTicket = tid
|
||||
, ticketAuthorRemoteAuthor = remoteAuthorId author
|
||||
, ticketAuthorRemoteOpen = offerID
|
||||
}
|
||||
return tid
|
||||
|
||||
insertMerge
|
||||
:: LoomId
|
||||
-> TicketId
|
||||
-> Maybe Text
|
||||
-> These
|
||||
(Either
|
||||
(RepoId, Maybe Text)
|
||||
(RemoteActorId, FedURI, Maybe (Maybe LocalURI, Text))
|
||||
)
|
||||
Material
|
||||
-> ActDB TicketLoomId
|
||||
insertMerge loomID ticketID maybeTargetBranch originOrBundle = do
|
||||
clothID <- insert $ TicketLoom ticketID loomID maybeTargetBranch
|
||||
for_ (justHere originOrBundle) $ \case
|
||||
Left (repoID, maybeOriginBranch) ->
|
||||
insert_ $ MergeOriginLocal clothID repoID maybeOriginBranch
|
||||
Right (remoteActorID, _uClone, maybeOriginBranch) -> do
|
||||
originID <- insert $ MergeOriginRemote clothID remoteActorID
|
||||
for_ maybeOriginBranch $ \ (mlu, b) ->
|
||||
insert_ $ MergeOriginRemoteBranch originID mlu b
|
||||
for_ (justThere originOrBundle) $ \ (Material typ diffs) -> do
|
||||
bundleID <- insert $ Bundle clothID False
|
||||
insertMany_ $ NE.toList $ NE.reverse $
|
||||
NE.map (Patch bundleID now typ) diffs
|
||||
return clothID
|
||||
|
||||
prepareAccept clothID = do
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
|
||||
audSender <- makeAudSenderWithFollowers authorIdMsig
|
||||
loomHash <- encodeKeyHashid loomID
|
||||
clothHash <- encodeKeyHashid clothID
|
||||
let audLoom = AudLocal [] [LocalStageLoomFollowers loomHash]
|
||||
uOffer <- lift $ getActivityURI authorIdMsig
|
||||
|
||||
let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
|
||||
collectAudience [audSender, audLoom]
|
||||
|
||||
recips = map encodeRouteHome audLocal ++ audRemote
|
||||
action = AP.Action
|
||||
{ AP.actionCapability = Nothing
|
||||
, AP.actionSummary = Nothing
|
||||
, AP.actionAudience = AP.Audience recips [] [] [] [] []
|
||||
, AP.actionFulfills = [uOffer]
|
||||
, AP.actionSpecific = AP.AcceptActivity AP.Accept
|
||||
{ AP.acceptObject = uOffer
|
||||
, AP.acceptResult =
|
||||
Just $ encodeRouteLocal $ ClothR loomHash clothHash
|
||||
}
|
||||
}
|
||||
|
||||
return (action, recipientSet, remoteActors, fwdHosts)
|
||||
|
||||
loomBehavior :: UTCTime -> LoomId -> VerseExt -> ActE (Text, Act (), Next)
|
||||
loomBehavior now loomID (Left _verse@(Verse _authorIdMsig body)) =
|
||||
loomBehavior now loomID (Left verse@(Verse _authorIdMsig body)) =
|
||||
case AP.activitySpecific $ actbActivity body of
|
||||
AP.OfferActivity offer -> loomOffer now loomID verse offer
|
||||
_ -> throwE "Unsupported activity type for Loom"
|
||||
loomBehavior _ _ (Right _) = throwE "ClientMsgs aren't supported for Loom"
|
||||
|
||||
|
|
|
|||
|
|
@ -18,11 +18,10 @@
|
|||
|
||||
module Vervis.Federation.Ticket
|
||||
( --personOfferTicketF
|
||||
loomOfferTicketF
|
||||
|
||||
--, repoAddBundleF
|
||||
|
||||
, loomApplyF
|
||||
loomApplyF
|
||||
|
||||
--, deckOfferDepF
|
||||
--, repoOfferDepF
|
||||
|
|
@ -328,336 +327,6 @@ activityAlreadyInInbox hAct luAct inboxID = fmap isJust . runMaybeT $ do
|
|||
remoteActivityID <- MaybeT $ getKeyBy $ UniqueRemoteActivity remoteObjectID
|
||||
MaybeT $ getBy $ UniqueInboxItemRemote inboxID remoteActivityID
|
||||
|
||||
loomOfferTicketF
|
||||
:: UTCTime
|
||||
-> KeyHashid Loom
|
||||
-> RemoteAuthor
|
||||
-> ActivityBody
|
||||
-> Maybe (RecipientRoutes, ByteString)
|
||||
-> LocalURI
|
||||
-> AP.Ticket URIMode
|
||||
-> FedURI
|
||||
-> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
|
||||
loomOfferTicketF now recipLoomHash author body mfwd luOffer ticket uTarget = do
|
||||
error "loomOfferTicketF disabled for refactoring"
|
||||
{-
|
||||
-- Check input
|
||||
recipLoomID <- decodeKeyHashid404 recipLoomHash
|
||||
(title, desc, source, originTipOrBundle, targetRepoID, maybeTargetBranch) <- do
|
||||
let uAuthor@(ObjURI hAuthor _) = remoteAuthorURI author
|
||||
WorkItemOffer {..} <- checkOfferTicket hAuthor ticket uTarget
|
||||
unless (wioAuthor == Right (remoteAuthorURI author)) $
|
||||
throwE "Offering a Ticket attributed to someone else"
|
||||
Merge maybeOriginTip maybeBundle targetTip <- case wioRest of
|
||||
TAM_Task _ ->
|
||||
throwE
|
||||
"Offer target is some local deck, so I have no use for \
|
||||
\this Offer. Was I supposed to receive it?"
|
||||
TAM_Merge loomID merge ->
|
||||
if loomID == recipLoomID
|
||||
then return merge
|
||||
else throwE
|
||||
"Offer target is some other local loom, so I have \
|
||||
\no use for this Offer. Was I supposed to receive \
|
||||
\it?"
|
||||
TAM_Remote _ _ ->
|
||||
throwE
|
||||
"Offer target is some remote tracker, so I have no use \
|
||||
\for this Offer. Was I supposed to receive it?"
|
||||
originTipOrBundle <-
|
||||
fromMaybeE
|
||||
(align maybeOriginTip maybeBundle)
|
||||
"MR provides neither origin nor patches"
|
||||
(targetRepoID, maybeTargetBranch) <-
|
||||
case targetTip of
|
||||
TipLocalRepo repoID -> pure (repoID, Nothing)
|
||||
TipLocalBranch repoID branch -> pure (repoID, Just branch)
|
||||
_ -> throwE "MR target is a remote repo (this tracker serves only local repos)"
|
||||
return (wioTitle, wioDesc, wioSource, originTipOrBundle, targetRepoID, maybeTargetBranch)
|
||||
|
||||
-- Soon we're going to proceed asynchronously to be able to HTTP GET the
|
||||
-- origin repo AP object, because:
|
||||
--
|
||||
-- * No support for providing a signed repo object directly in the
|
||||
-- Offer activity
|
||||
-- * It may be nice to make sure a remote origin repo's VCS type
|
||||
-- matches the target repo's VCS, even if patches are provided too
|
||||
-- + However there's no support for caching VCS type when
|
||||
-- remembering remote repo in our DB, so we'd have to check this
|
||||
-- every time
|
||||
-- * If origin is remote and no patches are provided, we'll need to
|
||||
-- know the clone URL to generate the patches ourselves
|
||||
-- + However the code here, for some simplicity, doesn't have a
|
||||
-- way to skip that and do the whole handler synchronously in
|
||||
-- case patches are provided or the origin is a local repo
|
||||
-- + And no support for caching the clone URI in DB when
|
||||
-- remembering the remote repo, so we'd need to do this every
|
||||
-- time
|
||||
--
|
||||
-- So first let's do some checks using the DB, on the loom, on the target
|
||||
-- repo (which is always local), and on the origin repo if it's local
|
||||
(recipLoomRepoID, Entity recipLoomActorID recipLoomActor, alreadyInInbox) <- lift $ runDB $ do
|
||||
|
||||
-- Find recipient loom in DB, returning 404 if doesn't exist because
|
||||
-- we're in the loom's inbox post handler
|
||||
(recipLoomRepoID, recipLoomActor@(Entity _ actor)) <- do
|
||||
loom <- get404 recipLoomID
|
||||
let actorID = loomActor loom
|
||||
(loomRepo loom,) . Entity actorID <$> getJust actorID
|
||||
|
||||
-- Has the loom already received this activity to its inbox? If yes, we
|
||||
-- won't process it again
|
||||
alreadyInInbox <- do
|
||||
let hOffer = objUriAuthority $ remoteAuthorURI author
|
||||
activityAlreadyInInbox hOffer luOffer (actorInbox actor)
|
||||
|
||||
return (recipLoomRepoID, recipLoomActor, alreadyInInbox)
|
||||
|
||||
if alreadyInInbox
|
||||
then return ("I already have this activity in my inbox, ignoring", Nothing)
|
||||
else do
|
||||
(targetRepoVCS, originOrBundle) <- runDBExcept $ do
|
||||
|
||||
-- Grab loom's repo from DB and verify that it consents to be served by
|
||||
-- the loom, otherwise this loom doesn't accept tickets
|
||||
unless (targetRepoID == recipLoomRepoID) $
|
||||
throwE "MR target repo isn't the one served by the Offer target loom"
|
||||
targetRepo <- lift $ getJust targetRepoID
|
||||
unless (repoLoom targetRepo == Just recipLoomID) $
|
||||
throwE "Offer target loom doesn't have repo's consent to serve it"
|
||||
|
||||
-- Verify VCS type match between patch bundle and target repo
|
||||
for_ (justThere originTipOrBundle) $ \ (Material typ diffs) -> do
|
||||
unless (repoVcs targetRepo == patchMediaTypeVCS typ) $
|
||||
throwE "Patch type and local target repo VCS mismatch"
|
||||
case (typ, diffs) of
|
||||
(PatchMediaTypeDarcs, _ :| _ : _) ->
|
||||
throwE "More than one Darcs dpatch file provided"
|
||||
_ -> pure ()
|
||||
|
||||
-- If origin repo is local, find it in our DB and verify its VCS type
|
||||
-- matches the target repo
|
||||
originOrBundle <- flip (bifor originTipOrBundle) pure $ \ originTip -> do
|
||||
let origin =
|
||||
case originTip of
|
||||
TipLocalRepo repoID -> Left (repoID, Nothing)
|
||||
TipLocalBranch repoID branch -> Left (repoID, Just branch)
|
||||
TipRemote uOrigin -> Right (uOrigin, Nothing)
|
||||
TipRemoteBranch uRepo branch -> Right (uRepo, Just branch)
|
||||
bitraverse_
|
||||
(\ (repoID, maybeBranch) -> do
|
||||
repo <- getE repoID "MR origin local repo not found in DB"
|
||||
unless (repoVcs repo == repoVcs targetRepo) $
|
||||
throwE "Local origin repo VCS differs from target repo VCS"
|
||||
)
|
||||
pure
|
||||
origin
|
||||
return origin
|
||||
|
||||
return (repoVcs targetRepo, originOrBundle)
|
||||
|
||||
return $ (,) "Ran initial checks, doing the rest asynchronously" $ Just $ do
|
||||
|
||||
-- If origin repo is remote, HTTP GET its AP representation and
|
||||
-- remember it in our DB
|
||||
originOrBundle' <-
|
||||
bitraverse
|
||||
(bitraverse
|
||||
pure
|
||||
(\ (uOrigin, maybeOriginBranch) -> do
|
||||
(vcs, remoteOrigin) <-
|
||||
case maybeOriginBranch of
|
||||
Nothing -> do
|
||||
(vcs, raid, uClone, mb) <- withExceptT (T.pack . show) $ httpGetRemoteTip uOrigin
|
||||
return (vcs, (raid, uClone, first Just <$> mb))
|
||||
Just branch -> do
|
||||
(vcs, raid, uClone) <- withExceptT (T.pack . show) $ httpGetRemoteRepo uOrigin
|
||||
return (vcs, (raid, uClone, Just (Nothing, branch)))
|
||||
unless (vcs == targetRepoVCS) $
|
||||
throwE "Remote origin repo VCS differs from target repo VCS"
|
||||
return remoteOrigin
|
||||
)
|
||||
)
|
||||
pure
|
||||
originOrBundle
|
||||
|
||||
-- Verify that branches are specified for Git and aren't specified for
|
||||
-- Darcs
|
||||
-- Also, produce a data structure separating by VCS rather than by
|
||||
-- local/remote origin, which we'll need for generating patches
|
||||
tipInfo <- case targetRepoVCS of
|
||||
VCSGit -> do
|
||||
targetBranch <- fromMaybeE maybeTargetBranch "Local target repo is Git but no target branch specified"
|
||||
maybeOrigin <- for (justHere originOrBundle') $ \case
|
||||
Left (originRepoID, maybeOriginBranch) -> do
|
||||
originBranch <- fromMaybeE maybeOriginBranch "Local origin repo is Git but no origin branch specified"
|
||||
return (Left originRepoID, originBranch)
|
||||
Right (_remoteActorID, uClone, maybeOriginBranch) -> do
|
||||
(_maybeURI, originBranch) <- fromMaybeE maybeOriginBranch "Remote origin repo is Git but no origin branch specified"
|
||||
return (Right uClone, originBranch)
|
||||
return $ Left (targetBranch, maybeOrigin)
|
||||
VCSDarcs -> do
|
||||
verifyNothingE maybeTargetBranch "Local target repo is Darcs but target branch specified"
|
||||
maybeOriginRepo <- for (justHere originOrBundle') $ \case
|
||||
Left (originRepoID, maybeOriginBranch) -> do
|
||||
verifyNothingE maybeOriginBranch "Local origin repo is Darcs but origin branch specified"
|
||||
return $ Left originRepoID
|
||||
Right (_remoteActorID, uClone, maybeOriginBranch) -> do
|
||||
verifyNothingE maybeOriginBranch "Remote origin repo is Darcs but origin branch specified"
|
||||
return $ Right uClone
|
||||
return $ Right $ maybeOriginRepo
|
||||
|
||||
maybeHttp <- runSiteDBExcept $ do
|
||||
|
||||
-- Insert the Offer to loom's inbox
|
||||
mractid <- lift $ insertToInbox now author body (actorInbox recipLoomActor) luOffer False
|
||||
for mractid $ \ offerID -> do
|
||||
|
||||
-- Forward the Offer activity to relevant local stages, and
|
||||
-- schedule delivery for unavailable remote members of them
|
||||
maybeHttpFwdOffer <- lift $ for mfwd $ \ (localRecips, sig) -> do
|
||||
let sieve =
|
||||
makeRecipientSet
|
||||
[]
|
||||
[LocalStageLoomFollowers recipLoomHash]
|
||||
forwardActivityDB
|
||||
(actbBL body) localRecips sig
|
||||
recipLoomActorID (LocalActorLoom recipLoomHash)
|
||||
sieve offerID
|
||||
|
||||
-- Insert the new ticket to our DB
|
||||
acceptID <- lift $ insertEmptyOutboxItem (actorOutbox recipLoomActor) now
|
||||
ticketID <- lift $ insertTicket now title desc source offerID acceptID
|
||||
clothID <- lift $ insertMerge recipLoomID ticketID maybeTargetBranch originOrBundle'
|
||||
let maybePull =
|
||||
let maybeTipInfo =
|
||||
case tipInfo of
|
||||
Left (b, mo) -> Left . (b,) <$> mo
|
||||
Right mo -> Right <$> mo
|
||||
hasBundle = isJust $ justThere originOrBundle'
|
||||
in (clothID, targetRepoID, hasBundle,) <$> maybeTipInfo
|
||||
|
||||
-- Prepare an Accept activity and insert to loom's outbox
|
||||
(actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
|
||||
lift $ prepareAccept clothID
|
||||
_luAccept <- lift $ updateOutboxItem (LocalActorLoom recipLoomID) acceptID actionAccept
|
||||
|
||||
-- Deliver the Accept to local recipients, and schedule delivery
|
||||
-- for unavailable remote recipients
|
||||
deliverHttpAccept <-
|
||||
deliverActivityDB
|
||||
(LocalActorLoom recipLoomHash) recipLoomActorID
|
||||
localRecipsAccept remoteRecipsAccept
|
||||
fwdHostsAccept acceptID actionAccept
|
||||
|
||||
-- Return instructions for HTTP inbox-forwarding of the Offer
|
||||
-- activity, and for HTTP delivery of the Accept activity to
|
||||
-- remote recipients, and for generating patches from
|
||||
-- the origin repo
|
||||
return
|
||||
(maybeHttpFwdOffer, deliverHttpAccept, maybePull)
|
||||
|
||||
-- Launch asynchronous HTTP forwarding of the Offer activity and HTTP
|
||||
-- delivery of the Accept activity, and generate patches if we opened
|
||||
-- a local MR that mentions just an origin
|
||||
case maybeHttp of
|
||||
Nothing ->
|
||||
return
|
||||
"When I started serving this activity, I didn't have it in my inbox, \
|
||||
\but now suddenly it seems I already do, so ignoring"
|
||||
Just (maybeHttpFwdOffer, deliverHttpAccept, maybePull) -> do
|
||||
forkWorker "loomOfferTicketF Accept HTTP delivery" deliverHttpAccept
|
||||
traverse generatePatches maybePull
|
||||
case maybeHttpFwdOffer of
|
||||
Nothing -> return "Opened a merge request, no inbox-forwarding to do"
|
||||
Just forwardHttpOffer -> do
|
||||
forkWorker "loomOfferTicketF inbox-forwarding" forwardHttpOffer
|
||||
return "Opened a merge request and ran inbox-forwarding of the Offer"
|
||||
|
||||
where
|
||||
|
||||
insertTicket now title desc source offerID acceptID = do
|
||||
did <- insert Discussion
|
||||
fsid <- insert FollowerSet
|
||||
tid <- insert Ticket
|
||||
{ ticketNumber = Nothing
|
||||
, ticketCreated = now
|
||||
, ticketTitle = title
|
||||
, ticketSource = source
|
||||
, ticketDescription = desc
|
||||
, ticketDiscuss = did
|
||||
, ticketFollowers = fsid
|
||||
, ticketAccept = acceptID
|
||||
}
|
||||
insert_ TicketAuthorRemote
|
||||
{ ticketAuthorRemoteTicket = tid
|
||||
, ticketAuthorRemoteAuthor = remoteAuthorId author
|
||||
, ticketAuthorRemoteOpen = offerID
|
||||
}
|
||||
return tid
|
||||
|
||||
insertMerge
|
||||
:: LoomId
|
||||
-> TicketId
|
||||
-> Maybe Text
|
||||
-> These
|
||||
(Either
|
||||
(RepoId, Maybe Text)
|
||||
(RemoteActorId, FedURI, Maybe (Maybe LocalURI, Text))
|
||||
)
|
||||
Material
|
||||
-> WorkerDB TicketLoomId
|
||||
insertMerge loomID ticketID maybeTargetBranch originOrBundle = do
|
||||
clothID <- insert $ TicketLoom ticketID loomID maybeTargetBranch
|
||||
for_ (justHere originOrBundle) $ \case
|
||||
Left (repoID, maybeOriginBranch) ->
|
||||
insert_ $ MergeOriginLocal clothID repoID maybeOriginBranch
|
||||
Right (remoteActorID, _uClone, maybeOriginBranch) -> do
|
||||
originID <- insert $ MergeOriginRemote clothID remoteActorID
|
||||
for_ maybeOriginBranch $ \ (mlu, b) ->
|
||||
insert_ $ MergeOriginRemoteBranch originID mlu b
|
||||
for_ (justThere originOrBundle) $ \ (Material typ diffs) -> do
|
||||
bundleID <- insert $ Bundle clothID False
|
||||
insertMany_ $ NE.toList $ NE.reverse $
|
||||
NE.map (Patch bundleID now typ) diffs
|
||||
return clothID
|
||||
|
||||
prepareAccept clothID = do
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
|
||||
clothHash <- encodeKeyHashid clothID
|
||||
|
||||
ra <- getJust $ remoteAuthorId author
|
||||
|
||||
let ObjURI hAuthor luAuthor = remoteAuthorURI author
|
||||
|
||||
audSender =
|
||||
AudRemote hAuthor
|
||||
[luAuthor]
|
||||
(maybeToList $ remoteActorFollowers ra)
|
||||
audTracker = AudLocal [] [LocalStageLoomFollowers recipLoomHash]
|
||||
|
||||
(recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
|
||||
collectAudience [audSender, audTracker]
|
||||
|
||||
recips = map encodeRouteHome audLocal ++ audRemote
|
||||
action = AP.Action
|
||||
{ AP.actionCapability = Nothing
|
||||
, AP.actionSummary = Nothing
|
||||
, AP.actionAudience = AP.Audience recips [] [] [] [] []
|
||||
, AP.actionFulfills = []
|
||||
, AP.actionSpecific = AP.AcceptActivity AP.Accept
|
||||
{ AP.acceptObject = ObjURI hAuthor luOffer
|
||||
, AP.acceptResult =
|
||||
Just $ encodeRouteLocal $
|
||||
ClothR recipLoomHash clothHash
|
||||
}
|
||||
}
|
||||
|
||||
return (action, recipientSet, remoteActors, fwdHosts)
|
||||
-}
|
||||
|
||||
repoOfferTicketF
|
||||
:: UTCTime
|
||||
-> KeyHashid Repo
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
{- This file is part of Vervis.
|
||||
-
|
||||
- Written in 2022 by fr33domlover <fr33domlover@riseup.net>.
|
||||
- Written in 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
|
||||
-
|
||||
- ♡ Copying is an act of love. Please copy, reuse and share.
|
||||
-
|
||||
|
|
@ -16,7 +16,9 @@
|
|||
module Vervis.Fetch
|
||||
( Result (..)
|
||||
, httpGetRemoteTip
|
||||
, httpGetRemoteTip'
|
||||
, httpGetRemoteRepo
|
||||
, httpGetRemoteRepo'
|
||||
)
|
||||
where
|
||||
|
||||
|
|
@ -60,6 +62,7 @@ import qualified Data.Text as T
|
|||
import qualified Data.Text.Encoding as TE
|
||||
import qualified Data.Text.Lazy as TL
|
||||
|
||||
import Control.Concurrent.Actor
|
||||
import Database.Persist.JSON
|
||||
import Development.PatchMediaType
|
||||
import Network.FedURI
|
||||
|
|
@ -81,6 +84,7 @@ import qualified Data.Text.UTF8.Local as TU
|
|||
import qualified Darcs.Local.Repository as D (createRepo)
|
||||
|
||||
--import Vervis.Access
|
||||
import Vervis.Actor
|
||||
import Vervis.ActivityPub
|
||||
import Vervis.Cloth
|
||||
import Vervis.Data.Actor
|
||||
|
|
@ -116,6 +120,13 @@ fetchRepoE h lu = do
|
|||
ExceptT $ first (maybe ResultIdMismatch ResultGetError) <$>
|
||||
fetchAPID' manager apRepoId h lu
|
||||
|
||||
fetchRepoE' :: Host -> LocalURI -> ExceptT Result Act (AP.Repo URIMode)
|
||||
fetchRepoE' h lu = do
|
||||
manager <- asksEnv envHttpManager
|
||||
let apRepoId = AP.actorId . AP.actorLocal . AP.repoActor
|
||||
ExceptT $ first (maybe ResultIdMismatch ResultGetError) <$>
|
||||
fetchAPID' manager apRepoId h lu
|
||||
|
||||
insertRemoteActor
|
||||
:: MonadIO m
|
||||
=> Host
|
||||
|
|
@ -167,6 +178,36 @@ httpGetRemoteTip (ObjURI host localURI) = do
|
|||
ExceptT $ first (maybe ResultIdMismatch ResultGetError) <$>
|
||||
fetchTip manager h lu
|
||||
|
||||
httpGetRemoteTip'
|
||||
:: FedURI
|
||||
-> ExceptT Result Act
|
||||
( VersionControlSystem
|
||||
, RemoteActorId
|
||||
, FedURI
|
||||
, Maybe (LocalURI, Text)
|
||||
)
|
||||
httpGetRemoteTip' (ObjURI host localURI) = do
|
||||
repoOrBranch <- fetchTipE host localURI
|
||||
case repoOrBranch of
|
||||
Left repo -> do
|
||||
remoteActorID <-
|
||||
lift $ withDB $
|
||||
insertRemoteActor host localURI $ AP.repoActor repo
|
||||
let uClone = ObjURI host $ NE.head $ AP.repoClone repo
|
||||
return (AP.repoVcs repo, remoteActorID, uClone, Nothing)
|
||||
Right (AP.Branch name _ luRepo) -> do
|
||||
repo <- fetchRepoE' host luRepo
|
||||
remoteActorID <-
|
||||
lift $ withDB $
|
||||
insertRemoteActor host luRepo $ AP.repoActor repo
|
||||
let uClone = ObjURI host $ NE.head $ AP.repoClone repo
|
||||
return (AP.repoVcs repo, remoteActorID, uClone, Just (localURI, name))
|
||||
where
|
||||
fetchTipE h lu = do
|
||||
manager <- asksEnv envHttpManager
|
||||
ExceptT $ first (maybe ResultIdMismatch ResultGetError) <$>
|
||||
fetchTip manager h lu
|
||||
|
||||
httpGetRemoteRepo
|
||||
:: (MonadUnliftIO m, MonadSite m, SiteEnv m ~ App)
|
||||
=> FedURI
|
||||
|
|
@ -178,3 +219,14 @@ httpGetRemoteRepo (ObjURI host localURI) = do
|
|||
insertRemoteActor host localURI $ AP.repoActor repo
|
||||
let uClone = ObjURI host $ NE.head $ AP.repoClone repo
|
||||
return (AP.repoVcs repo, remoteActorID, uClone)
|
||||
|
||||
httpGetRemoteRepo'
|
||||
:: FedURI
|
||||
-> ExceptT Result Act (VersionControlSystem, RemoteActorId, FedURI)
|
||||
httpGetRemoteRepo' (ObjURI host localURI) = do
|
||||
repo <- fetchRepoE' host localURI
|
||||
remoteActorID <-
|
||||
lift $ withDB $
|
||||
insertRemoteActor host localURI $ AP.repoActor repo
|
||||
let uClone = ObjURI host $ NE.head $ AP.repoClone repo
|
||||
return (AP.repoVcs repo, remoteActorID, uClone)
|
||||
|
|
|
|||
|
|
@ -222,7 +222,6 @@ postPersonOutboxR personHash = do
|
|||
-> t
|
||||
run f = f eperson actorDB maybeCap localRecips remoteRecips fwdHosts action
|
||||
case specific of
|
||||
AP.AcceptActivity accept -> run acceptC accept
|
||||
AP.ApplyActivity apply -> run applyC apply
|
||||
AP.CreateActivity (AP.Create obj mtarget) ->
|
||||
case obj of
|
||||
|
|
@ -246,7 +245,10 @@ postPersonOutboxR personHash = do
|
|||
AP.FollowActivity follow -> run followC follow
|
||||
AP.OfferActivity (AP.Offer obj target) ->
|
||||
case obj of
|
||||
AP.OfferTicket ticket -> run offerTicketC ticket target
|
||||
AP.OfferTicket _ ->
|
||||
handleViaActor
|
||||
(entityKey eperson) maybeCap localRecips remoteRecips
|
||||
fwdHosts action
|
||||
{-
|
||||
OfferDep dep ->
|
||||
offerDepC eperson sharer summary audience dep target
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
{- This file is part of Vervis.
|
||||
-
|
||||
- Written in 2016, 2019, 2022 by fr33domlover <fr33domlover@riseup.net>.
|
||||
- Written in 2016, 2019, 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
|
||||
-
|
||||
- ♡ Copying is an act of love. Please copy, reuse and share.
|
||||
-
|
||||
|
|
@ -17,6 +17,7 @@ module Vervis.Path
|
|||
( askRepoRootDir
|
||||
, repoDir
|
||||
, askRepoDir
|
||||
, askRepoDir'
|
||||
)
|
||||
where
|
||||
|
||||
|
|
@ -26,9 +27,11 @@ import System.FilePath ((</>))
|
|||
import qualified Data.CaseInsensitive as CI (foldedCase)
|
||||
import qualified Data.Text as T (unpack)
|
||||
|
||||
import Control.Concurrent.Actor
|
||||
import Yesod.Hashids
|
||||
import Yesod.MonadSite
|
||||
|
||||
import Vervis.Actor
|
||||
import Vervis.Foundation
|
||||
import Vervis.Model
|
||||
import Vervis.Settings
|
||||
|
|
@ -36,6 +39,9 @@ import Vervis.Settings
|
|||
askRepoRootDir :: (MonadSite m, SiteEnv m ~ App) => m FilePath
|
||||
askRepoRootDir = asksSite $ appRepoDir . appSettings
|
||||
|
||||
askRepoRootDir' :: Act FilePath
|
||||
askRepoRootDir' = asksEnv $ appRepoDir . envSettings
|
||||
|
||||
repoDir :: FilePath -> KeyHashid Repo -> FilePath
|
||||
repoDir root repo = root </> (T.unpack $ keyHashidText repo)
|
||||
|
||||
|
|
@ -44,3 +50,8 @@ askRepoDir
|
|||
askRepoDir repo = do
|
||||
root <- askRepoRootDir
|
||||
return $ repoDir root repo
|
||||
|
||||
askRepoDir' :: KeyHashid Repo -> Act FilePath
|
||||
askRepoDir' repo = do
|
||||
root <- askRepoRootDir'
|
||||
return $ repoDir root repo
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
{- This file is part of Vervis.
|
||||
-
|
||||
- Written in 2019, 2020, 2021, 2022 by fr33domlover <fr33domlover@riseup.net>.
|
||||
- Written in 2019, 2020, 2021, 2022, 2023
|
||||
- by fr33domlover <fr33domlover@riseup.net>.
|
||||
-
|
||||
- ♡ Copying is an act of love. Please copy, reuse and share.
|
||||
-
|
||||
|
|
@ -45,11 +46,13 @@ import Yesod.Hashids
|
|||
import Yesod.MonadSite
|
||||
|
||||
import qualified Web.ActivityPub as AP
|
||||
import qualified Web.Actor.Persist as WAP
|
||||
|
||||
import Data.Patch.Local hiding (Patch)
|
||||
|
||||
import qualified Data.Patch.Local as P
|
||||
|
||||
import Vervis.Actor
|
||||
import Vervis.Darcs
|
||||
import Vervis.FedURI
|
||||
import Vervis.Foundation
|
||||
|
|
@ -110,36 +113,35 @@ serveCommit repoHash ref patch parents = do
|
|||
Right $ encodeRouteHome $ PersonR $ hashPerson personID
|
||||
|
||||
generatePatches
|
||||
:: (MonadUnliftIO m, MonadSite m, SiteEnv m ~ App)
|
||||
=> ( TicketLoomId
|
||||
:: ( TicketLoomId
|
||||
, RepoId
|
||||
, Bool
|
||||
, Either
|
||||
(Text, (Either RepoId FedURI, Text))
|
||||
(Either RepoId FedURI)
|
||||
)
|
||||
-> ExceptT Text m ()
|
||||
-> ActE ()
|
||||
generatePatches (clothID, targetRepoID, hasBundle, tipInfo) = unless hasBundle $ do
|
||||
patches <-
|
||||
case tipInfo of
|
||||
Right _ -> error "Auto-pulling from Darcs remote origin not supported yet"
|
||||
Left (targetBranch, (originRepo, originBranch)) -> do
|
||||
targetPath <- do
|
||||
repoHash <- encodeKeyHashid targetRepoID
|
||||
repoDir <- askRepoDir repoHash
|
||||
repoHash <- WAP.encodeKeyHashid targetRepoID
|
||||
repoDir <- lift $ askRepoDir' repoHash
|
||||
liftIO $ makeAbsolute repoDir
|
||||
originURI <-
|
||||
case originRepo of
|
||||
Left repoID -> do
|
||||
repoHash <- encodeKeyHashid repoID
|
||||
repoDir <- askRepoDir repoHash
|
||||
repoHash <- WAP.encodeKeyHashid repoID
|
||||
repoDir <- lift $ askRepoDir' repoHash
|
||||
liftIO $ makeAbsolute repoDir
|
||||
Right uClone -> pure $ T.unpack $ renderObjURI uClone
|
||||
ExceptT $ liftIO $ runExceptT $
|
||||
withSystemTempDirectory "vervis-generatePatches" $
|
||||
generateGitPatches targetPath (T.unpack targetBranch) originURI (T.unpack originBranch)
|
||||
now <- liftIO getCurrentTime
|
||||
lift $ runSiteDB $ do
|
||||
lift $ withDB $ do
|
||||
bundleID <- insert $ Bundle clothID True
|
||||
insertMany_ $ NE.toList $ NE.map (Patch bundleID now PatchMediaTypeGit) $ NE.reverse patches
|
||||
|
||||
|
|
|
|||
Loading…
Reference in a new issue