From c3ff3c40ebfae1e91957450e70a39a1f4085c7b8 Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Thu, 23 Jun 2022 09:09:02 +0000 Subject: [PATCH] S2S: repoApplyF, for now only on remotely hosted patches --- migrations/2016_08_04.model | 2 +- src/Development/PatchMediaType.hs | 2 +- src/Vervis/Access.hs | 1 + src/Vervis/ActivityPub.hs | 32 ++- src/Vervis/Federation.hs | 4 +- src/Vervis/Federation/Ticket.hs | 396 +++++++++++++++++++++++++++--- src/Vervis/Model/Role.hs | 1 + src/Vervis/Ticket.hs | 67 +++++ src/Web/ActivityPub.hs | 41 +++- stack.yaml | 2 +- vervis.cabal | 7 +- 11 files changed, 489 insertions(+), 66 deletions(-) diff --git a/migrations/2016_08_04.model b/migrations/2016_08_04.model index 7b91a8c..460b922 100644 --- a/migrations/2016_08_04.model +++ b/migrations/2016_08_04.model @@ -68,7 +68,7 @@ RepoRoleInherit RepoAccess role RepoRoleId - op RepoOperation + op Text UniqueRepoAccess role op diff --git a/src/Development/PatchMediaType.hs b/src/Development/PatchMediaType.hs index 6686aa7..1933f32 100644 --- a/src/Development/PatchMediaType.hs +++ b/src/Development/PatchMediaType.hs @@ -36,7 +36,7 @@ data VersionControlSystem = VCSDarcs | VCSGit deriving Eq data PatchMediaType = PatchMediaTypeDarcs deriving Eq forgeFedPrefix :: Text -forgeFedPrefix = "https://forgefed.peers.community/ns#" +forgeFedPrefix = "https://forgefed.org/ns#" parseVersionControlSystemName :: Text -> Maybe VersionControlSystem parseVersionControlSystemName = parse . T.toLower diff --git a/src/Vervis/Access.hs b/src/Vervis/Access.hs index 08c0a0e..bbfa30b 100644 --- a/src/Vervis/Access.hs +++ b/src/Vervis/Access.hs @@ -101,6 +101,7 @@ roleHasAccess User op = pure $ userAccess op userAccess ProjOpAddTicketDep = False userAccess ProjOpRemoveTicketDep = False userAccess ProjOpPush = False + userAccess ProjOpApplyPatch = False roleHasAccess Guest _ = pure False roleHasAccess (RoleID rlid) op = fmap isJust . runMaybeT $ diff --git a/src/Vervis/ActivityPub.hs b/src/Vervis/ActivityPub.hs index 6e5ceb3..569fcd2 100644 --- a/src/Vervis/ActivityPub.hs +++ b/src/Vervis/ActivityPub.hs @@ -53,6 +53,7 @@ module Vervis.ActivityPub , verifyContentTypeAP , verifyContentTypeAP_E , parseActivity + , parseActivityURI , getActivity , ActorEntity (..) , getOutboxActorEntity @@ -1221,22 +1222,33 @@ verifyContentTypeAP_E = do "application/ld+json; \ \profile=\"https://www.w3.org/ns/activitystreams\"" -parseActivity u@(ObjURI h lu) = do +-- | If the given URI is remote, return as is. If the URI is local, verify that +-- it parses as an activity URI, i.e. an outbox item route, and return the +-- parsed route. +parseActivityURI name u@(ObjURI h lu) = do hl <- hostIsLocal h if hl then Left <$> do - route <- fromMaybeE (decodeRouteLocal lu) "Object isn't a valid route" + route <- + fromMaybeE + (decodeRouteLocal lu) + (name <> " is local but isn't a valid route") case route of SharerOutboxItemR shr obikhid -> - (LocalActorSharer shr,) <$> - decodeKeyHashidE obikhid "No such obikhid" - ProjectOutboxItemR shr prj obikhid -> do - (LocalActorProject shr prj,) <$> - decodeKeyHashidE obikhid "No such obikhid" - RepoOutboxItemR shr rp obikhid -> do - (LocalActorRepo shr rp,) <$> - decodeKeyHashidE obikhid "No such obikhid" + (LocalActorSharer shr,) <$> decodeKH obikhid + ProjectOutboxItemR shr prj obikhid -> + (LocalActorProject shr prj,) <$> decodeKH obikhid + RepoOutboxItemR shr rp obikhid -> + (LocalActorRepo shr rp,) <$> decodeKH obikhid + _ -> + throwE $ + name <> " is a valid local route, but isn't an outbox \ + \item route" else return $ Right u + where + decodeKH obikhid = decodeKeyHashidE obikhid (name <> ": Invalid obikhid") + +parseActivity = parseActivityURI "Activity URI" getActivity (Left (actor, obiid)) = Just . Left <$> do obid <- getActorOutbox actor diff --git a/src/Vervis/Federation.hs b/src/Vervis/Federation.hs index 42f3766..e9b66ad 100644 --- a/src/Vervis/Federation.hs +++ b/src/Vervis/Federation.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2019, 2020 by fr33domlover . + - Written in 2019, 2020, 2022 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -379,6 +379,8 @@ handleRepoInbox shrRecip rpRecip now auth body = do msig <- checkForward $ LocalActorRepo shrRecip rpRecip let mfwd = (localRecips,) <$> msig case activitySpecific $ actbActivity body of + ApplyActivity (AP.Apply uObject uTarget) -> + repoApplyF now shrRecip rpRecip remoteAuthor body mfwd luActivity uObject uTarget AddActivity (AP.Add obj target) -> case obj of Right (AddBundle patches) -> diff --git a/src/Vervis/Federation/Ticket.hs b/src/Vervis/Federation/Ticket.hs index 4f3f26c..560f68d 100644 --- a/src/Vervis/Federation/Ticket.hs +++ b/src/Vervis/Federation/Ticket.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2019, 2020 by fr33domlover . + - Written in 2019, 2020, 2021, 2022 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -25,6 +25,8 @@ module Vervis.Federation.Ticket , sharerAddBundleF , repoAddBundleF + , repoApplyF + , sharerOfferDepF , projectOfferDepF , repoOfferDepF @@ -35,6 +37,7 @@ module Vervis.Federation.Ticket ) where +import Control.Applicative import Control.Exception hiding (Handler) import Control.Monad import Control.Monad.Logger.CallStack @@ -58,15 +61,19 @@ import Data.Time.Clock import Data.Traversable import Database.Persist import Database.Persist.Sql +import System.Exit +import System.Process.Typed import Text.Blaze.Html (preEscapedToHtml) import Text.Blaze.Html.Renderer.Text import Yesod.Core hiding (logError, logWarn, logInfo, logDebug) import Yesod.Core.Handler import Yesod.Persist.Core +import qualified Data.ByteString.Lazy as BL import qualified Data.List.NonEmpty as NE import qualified Data.List.Ordered as LO import qualified Data.Text as T +import qualified Data.Text.Encoding as TE import qualified Data.Text.Lazy as TL import Database.Persist.JSON @@ -84,6 +91,10 @@ import Data.Tuple.Local import Database.Persist.Local import Yesod.Persist.Local +import qualified Data.Text.UTF8.Local as TU + +import Development.PatchMediaType + import Vervis.ActivityPub import Vervis.ActivityPub.Recipient import Vervis.FedURI @@ -92,12 +103,37 @@ import Vervis.Federation.Util import Vervis.Foundation import Vervis.Model import Vervis.Model.Ident -import Development.PatchMediaType +import Vervis.Model.Role import Vervis.Model.Ticket import Vervis.Patch +import Vervis.Path +import Vervis.Query import Vervis.Ticket import Vervis.WorkItem +checkBranch + :: Host + -> LocalURI + -> ExceptT Text Handler (Either (ShrIdent, RpIdent, Maybe Text) FedURI) +checkBranch h lu = do + hl <- hostIsLocal h + if hl + then Left <$> do + route <- + fromMaybeE + (decodeRouteLocal lu) + "MR target is local but isn't a valid route" + case route of + RepoR shr rp -> return (shr, rp, Nothing) + RepoBranchR shr rp b -> return (shr, rp, Just b) + _ -> + throwE + "MR target is a valid local route, but isn't a repo \ + \or branch route" + else return $ Right $ ObjURI h lu + +checkBranch' (ObjURI h lu) = checkBranch h lu + checkOfferTicket :: RemoteAuthor -> AP.Ticket URIMode @@ -163,22 +199,6 @@ checkOfferTicket author ticket uTarget = do _ -> return () return (branch, typ, diffs) where - checkBranch h lu = do - hl <- hostIsLocal h - if hl - then Left <$> do - route <- - fromMaybeE - (decodeRouteLocal lu) - "MR target is local but isn't a valid route" - case route of - RepoR shr rp -> return (shr, rp, Nothing) - RepoBranchR shr rp b -> return (shr, rp, Just b) - _ -> - throwE - "MR target is a valid local route, but isn't a \ - \repo or branch route" - else return $ Right $ ObjURI h lu checkBundle _ (AP.BundleHosted _ _) = throwE "Patches specified as URIs" checkBundle h (AP.BundleOffer mlocal patches) = do @@ -626,27 +646,6 @@ checkCreateTicket author ticket muTarget = do _ -> return () return (branch, typ, patches) where - checkBranch - :: Host - -> LocalURI - -> ExceptT Text Handler - (Either (ShrIdent, RpIdent, Maybe Text) FedURI) - checkBranch h lu = do - hl <- hostIsLocal h - if hl - then Left <$> do - route <- - fromMaybeE - (decodeRouteLocal lu) - "MR target is local but isn't a valid route" - case route of - RepoR shr rp -> return (shr, rp, Nothing) - RepoBranchR shr rp b -> return (shr, rp, Just b) - _ -> - throwE - "MR target is a valid local route, but isn't a \ - \repo or branch route" - else return $ Right $ ObjURI h lu checkBundle _ (AP.BundleHosted _ _) = throwE "Patches specified as URIs" checkBundle h (AP.BundleOffer mblocal patches) = do @@ -1427,6 +1426,325 @@ repoAddBundleF now shrRecip rpRecip author body mfwd luAdd patches uTarget = do LocalPersonCollectionRepoProposalFollowers shrRecip rpRecip (hashLTID ltid) +repoApplyF + :: UTCTime + -> ShrIdent + -> RpIdent + -> RemoteAuthor + -> ActivityBody + -> Maybe (LocalRecipientSet, ByteString) + -> LocalURI + -> FedURI + -> FedURI + -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text)) +repoApplyF now shrRecip rpRecip author body mfwd luApply uObject uTarget = do + -- Verify the patch bundle URI is one of: + -- * A local sharer-hosted bundle + -- * A local repo-hosted bundle under the receiving repo + -- * A remote URI + bundle <- do + b <- parseProposalBundle "repoApplyF Apply object, a URI" uObject + case b of + Left (Right (shr, rp, ltid, bnid)) -> + if shr == shrRecip && rp == rpRecip + then return $ Left $ Right (ltid, bnid) + else throwE "Bundle is some other local repo's repo-hosted bundle" + Left (Left x) -> return $ Left $ Left x + Right u -> return $ Right u + + -- Verify the apply's target is one of: + -- * The URI of the receiving repo + -- * A local branch URI under the receiving repo + -- * A remote URI + mbranch <- do + target <- checkBranch' uTarget + case target of + Left (shr, rp, mb) | shr == shrRecip && rp == rpRecip -> return mb + _ -> throwE "Apply target isn't me, so, ignoring this activity" + + -- Verify the capability URI is one of: + -- * Outbox item URI of a local actor, i.e. a local activity + -- * A remote URI + capID <- do + let muCap = activityCapability $ actbActivity body + uCap <- fromMaybeE muCap "Asking to apply patch but no capability provided" + parseActivityURI "Apply capability" uCap + + -- Make sure receiving repo exists in DB, otherwise its inbox doesn't exist + -- either thus we return 404 + Entity ridRecip repoRecip <- lift $ runDB $ do + sid <- getKeyBy404 $ UniqueSharer shrRecip + getBy404 $ UniqueRepo rpRecip sid + return $ (,) "Ran initial checks, doing the rest asynchronously" $ Just $ do + case bundle of + Left (Left (shr, talid, bnid)) -> + error "Applying local bundle not supported yet" + + + + + Left (Right (ltid, bnid)) -> + error "Applying local bundle not supported yet" + + + + + + Right uBundle@(ObjURI hBundle luBundle) -> do + + -- Verify it's a latest-version bundle pointed by a ticket we + -- have listed under the receiving repo + manager <- asksSite appHttpManager + Doc h b <- withExceptT T.pack $ AP.fetchAP manager $ Left uBundle + (BundleLocal bid ctx _prevs mcurr, lus) <- + case b of + BundleHosted Nothing _ -> throwE "No bundle @id" + BundleHosted (Just l) ps -> return (l, ps) + BundleOffer _ _ -> throwE "Why does bundle contain patch objects" + unless (h == hBundle && bid == luBundle) $ + throwE "Bundle 'id' differs from the URI we fetched" + for_ mcurr $ \ curr -> + throwE $ + if curr == bid + then "Bundle currentVersion points to itself" + else "Bundle isn't the latest version" + let uTicket = ObjURI h ctx + Doc _ ticket <- withExceptT T.pack $ AP.fetchAP manager $ Left uTicket + (_, tlocal) <- fromMaybeE (AP.ticketLocal ticket) "Ticket has no @id" + (h', mr) <- fromMaybeE (AP.ticketAttachment ticket) "Ticket has no 'attachment'" + unless (ObjURI h' (mrTarget mr) == uTarget) $ + throwE "Ticket MR target isn't me / branch" + case mrBundle mr of + Left u -> + if u == uBundle + then pure () + else throwE "Bundle isn't the one pointed by ticket" + Right _ -> throwE "Ticket has bundle object instead of just URI" + e <- runSiteDBExcept $ getRemoteTicketByURI uTicket + case e of + Right (_, _, _, _, _, Right (Entity _ trl)) + | ticketRepoLocalRepo trl == ridRecip -> pure () + _ -> throwE "I don't have the ticket listed under me" + + -- Check in DB whether the provided capability matches a DB + -- record we have, and that it includes permission to apply MRs + runSiteDBExcept $ do + -- Find the activity itself by URI in the DB + act <- do + mact <- getActivity capID + fromMaybeE mact "Capability activity not known to me" + -- Find the Collab record for that activity + cid <- + case act of + Left (_actor, obiid) -> do + mcsl <- lift $ getValBy $ UniqueCollabSenderLocalActivity obiid + collabSenderLocalCollab <$> + fromMaybeE mcsl "Capability is a local activity but no matching capability" + Right ractid -> do + mcsr <- lift $ getValBy $ UniqueCollabSenderRemoteActivity ractid + collabSenderRemoteCollab <$> + fromMaybeE mcsr "Capability is a known remote activity but no matching capability" + -- Find the recipient of that Collab + raidCollab <- do + mcrr <- lift $ getValBy $ UniqueCollabRecipRemote cid + crr <- fromMaybeE mcrr "No remote recip for capability" + mcrl <- lift $ getBy $ UniqueCollabRecipLocal cid + verifyNothingE mcrl "Both local & remote recip for capability!" + return $ collabRecipRemoteActor crr + -- Verify the recipient is the author of the Apply activity + unless (raidCollab == remoteAuthorId author) $ + throwE "Collab recipient isn't the Apply author" + -- Find the repo to which this Collab gives access + ridCap <- do + mctlr <- lift $ getValBy $ UniqueCollabTopicLocalRepo cid + rid <- + collabTopicLocalRepoRepo <$> + fromMaybeE mctlr "Collab isn't for a repo" + mctlj <- lift $ getBy $ UniqueCollabTopicLocalProject cid + verifyNothingE mctlj "Collab topic duplicate, found project" + mctr <- lift $ getBy $ UniqueCollabTopicRemote cid + verifyNothingE mctr "Collab topic duplicate, found remote" + return rid + -- Verify that repo is us + unless (ridCap == ridRecip) $ + throwE "Capability topic is some other local repo" + -- Find the collaborator's role in the repo + mrlid <- + lift $ fmap collabRoleLocalRole <$> + getValBy (UniqueCollabRoleLocal cid) + -- If no role specified, that means Developer role with + -- access to apply changes to repo source code, otherwise + -- make sure the specified role (or an ancestor of it) has + -- access to the relevant operation + for_ mrlid $ \ rlid -> do + let roleHas role op = getBy $ UniqueRoleAccess role op + ancestorHas = flip getProjectRoleAncestorWithOpQ + roleHasAccess role op = + fmap isJust . runMaybeT $ + MaybeT (roleHas role op) <|> + MaybeT (ancestorHas role op) + has <- lift $ roleHasAccess rlid ProjOpApplyPatch + unless has $ + throwE + "Apply author's role in repo doesn't have \ + \ApplyPatch access" + + -- HTTP GET all the patches, examine and apply them + patches <- for lus $ \ luPatch -> do + Doc _ (AP.Patch mlocal _luAttrib _mpub typ content) <- + withExceptT T.pack $ AP.fetchAP manager $ Left $ ObjURI hBundle luPatch + (h, PatchLocal luP luC) <- fromMaybeE mlocal "No patch @id" + unless (ObjURI h luP == ObjURI hBundle luPatch) $ + throwE "Patch @id doesn't match the URI we fetched" + unless (luC == luBundle) $ + throwE "Patch doesn't point back to the bundle" + unless (patchMediaTypeVCS typ == repoVcs repoRecip) $ + throwE "Patch type and repo VCS mismatch" + return (typ, content) + case repoVcs repoRecip of + VCSGit -> error "Patching a Git repo unsupported yet" + VCSDarcs -> do + patch <- + case patches of + _ :| (_ : _) -> throwE "Darcs repo given multiple patch bundles" + (PatchMediaTypeDarcs, t) :| [] -> return t + path <- askRepoDir shrRecip rpRecip + let input = BL.fromStrict $ TE.encodeUtf8 patch + (exitCode, out, err) <- + readProcess $ setStdin (byteStringInput input) $ + proc "darcs" ["apply", "--all", "--no-allow-conflicts", "--repodir='" ++ path ++ "'"] + let out2text = TU.decodeLenient . BL.toStrict + case exitCode of + ExitFailure n -> + throwE $ + T.concat + [ "`darcs apply` failed with exit code " + , T.pack (show n) + , "\nstdout: ", out2text out + , "\nstderr: ", out2text err + ] + ExitSuccess -> return () + + -- Insert Apply activity to repo's inbox + -- Produce an Accept activity and deliver locally + mhttp <- lift $ runSiteDB $ do + mractid <- insertToInbox now author body (repoInbox repoRecip) luApply False + for mractid $ \ ractid -> do + mremotesHttpFwd <- for mfwd $ \ (localRecips, sig) -> do + let sieve = + makeRecipientSet + [] + [ LocalPersonCollectionRepoTeam shrRecip rpRecip + , LocalPersonCollectionRepoFollowers shrRecip rpRecip + ] + remoteRecips <- + insertRemoteActivityToLocalInboxes + False ractid $ + localRecipSieve' + sieve False False localRecips + (sig,) <$> deliverRemoteDB_R (actbBL body) ractid ridRecip sig remoteRecips + obiidAccept <- insertEmptyOutboxItem (repoOutbox repoRecip) now + (docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <- + insertAccept luApply hBundle tlocal obiidAccept + knownRemoteRecipsAccept <- + deliverLocal' + False + (LocalActorRepo shrRecip rpRecip) + (repoInbox repoRecip) + obiidAccept + localRecipsAccept + (mremotesHttpFwd, obiidAccept, docAccept, fwdHostsAccept,) <$> + deliverRemoteDB'' fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept + + -- Run inbox-forwarding on the Apply activity + -- Deliver Accept activity to remote recipients via HTTP + case mhttp of + Nothing -> return "I already have this activity in my inbox, doing nothing" + Just (mremotesHttpFwd, obiid, doc, fwdHosts, recips) -> do + for_ mremotesHttpFwd $ \ (sig, remotes) -> + forkWorker "repoApplyF inbox-forwarding" $ + deliverRemoteHTTP_R now shrRecip rpRecip (actbBL body) sig remotes + forkWorker "repoApplyF Accept HTTP delivery" $ + deliverRemoteHttp' fwdHosts obiid doc recips + return $ + if isJust mremotesHttpFwd + then "Applied patches, did inbox-forwarding" + else "Applied patches, no inbox-forwarding to do" + + {- + TODO to be clear: When a repo receives a Ticket, does it store the whole + ticket and bundle and patches in DB? + ANSWER: Yes, it does + + And when a repo is notified on a new bundle version for such a + remotely hosted Ticket, does it store this new bundle and its patches + in the local DB? + ANSWER: No, it stores only for a repo-hosted own Ticket + + TODO there are 3 options for the bundle referred by uObject: + 1: It's under a remote Ticket + 2: It's under a sharer-hosted local Ticket + 3: It's under a repo-hosted local Ticket + And here's what to do in each case: + 1: HTTP GET the bundle to check to which Ticket it belongs, then see + if this our repo has such a remotely-hosted Ticket + 2: Find this Bundle in DB, make sure indeed belongs to specified + sharer, and if so, does our repo have this Ticket listed? + 3: Does this repo-hosted ticket belong to our repo? Make sure in the + route and in the DB + + TODO if I'm the target, am I a darcs repo? + + TODO if a branch of mine is the target, am I a git repo? + + TODO do I have this bundle registered under a proposal I know? + + TODO is this bundle the latest version in that proposal? + -} + + where + + insertAccept luApply hTicket tlocal obiidAccept = do + encodeRouteLocal <- getEncodeRouteLocal + encodeRouteHome <- getEncodeRouteHome + hLocal <- asksSite siteInstanceHost + obikhidAccept <- encodeKeyHashid obiidAccept + ra <- getJust $ remoteAuthorId author + let ObjURI hAuthor luAuthor = remoteAuthorURI author + + audAuthor = + AudRemote hAuthor [luAuthor] (maybeToList $ remoteActorFollowers ra) + + audTicket = + AudRemote hTicket [] [AP.ticketParticipants tlocal] + + audRepo = + AudLocal + [] + [ LocalPersonCollectionRepoTeam shrRecip rpRecip + , LocalPersonCollectionRepoFollowers shrRecip rpRecip + ] + + (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = + collectAudience [audAuthor, audTicket, audRepo] + + recips = map encodeRouteHome audLocal ++ audRemote + doc = Doc hLocal Activity + { activityId = + Just $ encodeRouteLocal $ + RepoOutboxItemR shrRecip rpRecip obikhidAccept + , activityActor = encodeRouteLocal $ RepoR shrRecip rpRecip + , activityCapability = Nothing + , activitySummary = Nothing + , activityAudience = Audience recips [] [] [] [] [] + , activitySpecific = AcceptActivity Accept + { acceptObject = ObjURI hAuthor luApply + , acceptResult = Nothing + } + } + update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc] + return (doc, recipientSet, remoteActors, fwdHosts) + sharerOfferDepF :: UTCTime -> ShrIdent diff --git a/src/Vervis/Model/Role.hs b/src/Vervis/Model/Role.hs index 4c861ff..72921ed 100644 --- a/src/Vervis/Model/Role.hs +++ b/src/Vervis/Model/Role.hs @@ -33,6 +33,7 @@ data ProjectOperation | ProjOpAddTicketDep | ProjOpRemoveTicketDep | ProjOpPush + | ProjOpApplyPatch deriving (Eq, Show, Read, Enum, Bounded) derivePersistField "ProjectOperation" diff --git a/src/Vervis/Ticket.hs b/src/Vervis/Ticket.hs index e783031..f6b11a2 100644 --- a/src/Vervis/Ticket.hs +++ b/src/Vervis/Ticket.hs @@ -42,6 +42,8 @@ module Vervis.Ticket , askWorkItemRoute , getWorkItem , parseWorkItem + , parseProposalBundle + , getRemoteTicketByURI , checkDepAndTarget ) @@ -888,6 +890,71 @@ parseWorkItem name u@(ObjURI h lu) = do _ -> throwE $ name <> ": not a work item route" else return $ Right u +parseProposalBundle name u@(ObjURI h lu) = do + hl <- hostIsLocal h + if hl + then Left <$> do + route <- + fromMaybeE (decodeRouteLocal lu) $ + name <> ": Not a valid route" + case route of + SharerProposalBundleR shr talkhid bnkhid-> do + talid <- decodeKeyHashidE talkhid $ name <> ": Invalid talkhid" + bnid <- decodeKeyHashidE bnkhid $ name <> ": Invalid bnkhid" + return $ Left (shr, talid, bnid) + RepoProposalBundleR shr rp ltkhid bnkhid -> do + ltid <- decodeKeyHashidE ltkhid $ name <> ": Invalid ltkhid" + bnid <- decodeKeyHashidE bnkhid $ name <> ": Invalid bnkhid" + return $ Right (shr, rp, ltid, bnid) + _ -> throwE $ name <> ": not a bundle route" + else return $ Right u + +getRemoteTicketByURI + :: MonadIO m + => ObjURI URIMode + -> ExceptT Text (ReaderT SqlBackend m) + (Either + Text + ( Entity Instance + , Entity RemoteObject + , Entity RemoteTicket + , Entity TicketAuthorRemote + , Entity TicketContextLocal + , Either (Entity TicketProjectLocal) (Entity TicketRepoLocal) + ) + ) +getRemoteTicketByURI (ObjURI h lu) = adapt $ do + ei@(Entity iid _) <- do + mei <- lift $ getBy $ UniqueInstance h + fromMaybeE mei $ Right "Instance not known" + ero@(Entity roid _) <- do + mero <- lift $ getBy $ UniqueRemoteObject iid lu + fromMaybeE mero $ Right "Remote object not known" + ert@(Entity _ rt) <- do + mert <- lift $ getBy $ UniqueRemoteTicketIdent roid + fromMaybeE mert $ Right "Not a known RemoteTicket" + etar@(Entity _ tar) <- do + metar <- lift $ getEntity $ remoteTicketTicket rt + fromMaybeE metar $ Left "RT's TAR not found in DB" + etcl@(Entity tclid _) <- do + metcl <- lift $ getEntity $ ticketAuthorRemoteTicket tar + fromMaybeE metcl $ Left "TAR's TCL not found in DB" + ctx <- do + metjl <- lift $ getBy $ UniqueTicketProjectLocal tclid + metrl <- lift $ getBy $ UniqueTicketRepoLocal tclid + case (metjl, metrl) of + (Nothing, Nothing) -> throwE $ Left "TCL has neither TJL nor TRL" + (Just j, Nothing) -> return $ Left j + (Nothing, Just r) -> return $ Right r + (Just _, Just _) -> throwE $ Left "TCL has both TJL and TRL" + return (ei, ero, ert, etar, etcl, ctx) + where + adapt m = ExceptT $ adapt' <$> runExceptT m + where + adapt' (Left (Left e)) = Left e + adapt' (Left (Right e)) = Right $ Left e + adapt' (Right x) = Right $ Right x + checkDepAndTarget :: (MonadSite m, SiteEnv m ~ App) => TicketDependency URIMode diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index e25a9b5..e186032 100644 --- a/src/Web/ActivityPub.hs +++ b/src/Web/ActivityPub.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2019, 2020, 2021 by fr33domlover . + - Written in 2019, 2020, 2021, 2022 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -62,6 +62,7 @@ module Web.ActivityPub , Accept (..) , AddObject (..) , Add (..) + , Apply (..) , CreateObject (..) , Create (..) , Follow (..) @@ -163,10 +164,10 @@ as2Context :: Text as2Context = "https://www.w3.org/ns/activitystreams" secContext :: Text -secContext = "https://w3id.org/security/v1" +secContext = "https://w3id.org/security/v2" forgeContext :: Text -forgeContext = "https://forgefed.peers.community/ns" +forgeContext = "https://forgefed.org/ns" extContext :: Text extContext = "https://angeley.es/as2-ext" @@ -1334,6 +1335,22 @@ encodeAdd h (Add obj target) Right o -> "object" `pair` pairs (toSeries h o) <> "target" .= target +data Apply u = Apply + { applyObject :: ObjURI u + , applyTarget :: ObjURI u + } + +parseApply :: UriMode u => Object -> Parser (Apply u) +parseApply o = + Apply + <$> o .: "object" + <*> o .: "target" + +encodeApply :: UriMode u => Apply u -> Series +encodeApply (Apply obj target) + = "object" .= obj + <> "target" .= target + data CreateObject u = CreateNote (Note u) | CreateTicket (Ticket u) instance ActivityPub CreateObject where @@ -1488,15 +1505,16 @@ encodeUndo :: UriMode u => Authority u -> Undo u -> Series encodeUndo a (Undo obj) = "object" .= obj data SpecificActivity u - = AcceptActivity (Accept u) + = AcceptActivity (Accept u) | AddActivity (Add u) - | CreateActivity (Create u) - | FollowActivity (Follow u) - | OfferActivity (Offer u) - | PushActivity (Push u) - | RejectActivity (Reject u) + | ApplyActivity (Apply u) + | CreateActivity (Create u) + | FollowActivity (Follow u) + | OfferActivity (Offer u) + | PushActivity (Push u) + | RejectActivity (Reject u) | ResolveActivity (Resolve u) - | UndoActivity (Undo u) + | UndoActivity (Undo u) data Activity u = Activity { activityId :: Maybe LocalURI @@ -1523,6 +1541,7 @@ instance ActivityPub Activity where case typ of "Accept" -> AcceptActivity <$> parseAccept a o "Add" -> AddActivity <$> parseAdd o a + "Apply" -> ApplyActivity <$> parseApply o "Create" -> CreateActivity <$> parseCreate o a actor "Follow" -> FollowActivity <$> parseFollow o "Offer" -> OfferActivity <$> parseOffer o a actor @@ -1545,6 +1564,7 @@ instance ActivityPub Activity where activityType :: SpecificActivity u -> Text activityType (AcceptActivity _) = "Accept" activityType (AddActivity _) = "Add" + activityType (ApplyActivity _) = "Apply" activityType (CreateActivity _) = "Create" activityType (FollowActivity _) = "Follow" activityType (OfferActivity _) = "Offer" @@ -1554,6 +1574,7 @@ instance ActivityPub Activity where activityType (UndoActivity _) = "Undo" encodeSpecific h _ (AcceptActivity a) = encodeAccept h a encodeSpecific h _ (AddActivity a) = encodeAdd h a + encodeSpecific _ _ (ApplyActivity a) = encodeApply a encodeSpecific h u (CreateActivity a) = encodeCreate h u a encodeSpecific _ _ (FollowActivity a) = encodeFollow a encodeSpecific h u (OfferActivity a) = encodeOffer h u a diff --git a/stack.yaml b/stack.yaml index f5fa000..1632cf9 100644 --- a/stack.yaml +++ b/stack.yaml @@ -12,7 +12,7 @@ packages: # Packages to be pulled from upstream that are not in the resolver (e.g., # acme-missiles-0.3) extra-deps: - - git: https://dev.angeley.es/s/fr33domlover/r/yesod-auth-account + - git: https://dev.openheart.work/s/fr33domlover/r/yesod-auth-account commit: 2d19eea0fae58897a02372a84cc48e7696a4e288 - ./lib/darcs-lights - ./lib/darcs-rev diff --git a/vervis.cabal b/vervis.cabal index 828551e..356c3ca 100644 --- a/vervis.cabal +++ b/vervis.cabal @@ -8,8 +8,8 @@ description: Most of the source code is in the public domain using the CC0 public domain dedication, but the application as a whole has GPL dependencies, and is released under the AGPL 3 license. -homepage: https://dev.angeley.es/s/fr33domlover/p/vervis -bug-reports: https://dev.angeley.es/s/fr33domlover/p/vervis/t +homepage: https://dev.openheart.work/s/fr33domlover/p/vervis +bug-reports: https://dev.openheart.work/s/fr33domlover/p/vervis/t license: OtherLicense license-file: COPYING author: fr33domlover @@ -27,7 +27,7 @@ cabal-version: >=1.10 source-repository head type: darcs - location: https://dev.angeley.es/s/fr33domlover/r/vervis + location: https://dev.openheart.work/s/fr33domlover/r/vervis flag dev description: Turn on development settings, like auto-reload templates. @@ -363,6 +363,7 @@ library , transformers -- probably should be replaced with lenses once I learn , tuple + , typed-process -- For making git hooks executable, i.e. set file mode , unix -- For httpAPEither