S2S: repoApplyF, for now only on remotely hosted patches

This commit is contained in:
fr33domlover 2022-06-23 09:09:02 +00:00
parent 5491d0e495
commit c3ff3c40eb
11 changed files with 489 additions and 66 deletions

View file

@ -68,7 +68,7 @@ RepoRoleInherit
RepoAccess RepoAccess
role RepoRoleId role RepoRoleId
op RepoOperation op Text
UniqueRepoAccess role op UniqueRepoAccess role op

View file

@ -36,7 +36,7 @@ data VersionControlSystem = VCSDarcs | VCSGit deriving Eq
data PatchMediaType = PatchMediaTypeDarcs deriving Eq data PatchMediaType = PatchMediaTypeDarcs deriving Eq
forgeFedPrefix :: Text forgeFedPrefix :: Text
forgeFedPrefix = "https://forgefed.peers.community/ns#" forgeFedPrefix = "https://forgefed.org/ns#"
parseVersionControlSystemName :: Text -> Maybe VersionControlSystem parseVersionControlSystemName :: Text -> Maybe VersionControlSystem
parseVersionControlSystemName = parse . T.toLower parseVersionControlSystemName = parse . T.toLower

View file

@ -101,6 +101,7 @@ roleHasAccess User op = pure $ userAccess op
userAccess ProjOpAddTicketDep = False userAccess ProjOpAddTicketDep = False
userAccess ProjOpRemoveTicketDep = False userAccess ProjOpRemoveTicketDep = False
userAccess ProjOpPush = False userAccess ProjOpPush = False
userAccess ProjOpApplyPatch = False
roleHasAccess Guest _ = pure False roleHasAccess Guest _ = pure False
roleHasAccess (RoleID rlid) op = roleHasAccess (RoleID rlid) op =
fmap isJust . runMaybeT $ fmap isJust . runMaybeT $

View file

@ -53,6 +53,7 @@ module Vervis.ActivityPub
, verifyContentTypeAP , verifyContentTypeAP
, verifyContentTypeAP_E , verifyContentTypeAP_E
, parseActivity , parseActivity
, parseActivityURI
, getActivity , getActivity
, ActorEntity (..) , ActorEntity (..)
, getOutboxActorEntity , getOutboxActorEntity
@ -1221,22 +1222,33 @@ verifyContentTypeAP_E = do
"application/ld+json; \ "application/ld+json; \
\profile=\"https://www.w3.org/ns/activitystreams\"" \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 hl <- hostIsLocal h
if hl if hl
then Left <$> do 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 case route of
SharerOutboxItemR shr obikhid -> SharerOutboxItemR shr obikhid ->
(LocalActorSharer shr,) <$> (LocalActorSharer shr,) <$> decodeKH obikhid
decodeKeyHashidE obikhid "No such obikhid" ProjectOutboxItemR shr prj obikhid ->
ProjectOutboxItemR shr prj obikhid -> do (LocalActorProject shr prj,) <$> decodeKH obikhid
(LocalActorProject shr prj,) <$> RepoOutboxItemR shr rp obikhid ->
decodeKeyHashidE obikhid "No such obikhid" (LocalActorRepo shr rp,) <$> decodeKH obikhid
RepoOutboxItemR shr rp obikhid -> do _ ->
(LocalActorRepo shr rp,) <$> throwE $
decodeKeyHashidE obikhid "No such obikhid" name <> " is a valid local route, but isn't an outbox \
\item route"
else return $ Right u else return $ Right u
where
decodeKH obikhid = decodeKeyHashidE obikhid (name <> ": Invalid obikhid")
parseActivity = parseActivityURI "Activity URI"
getActivity (Left (actor, obiid)) = Just . Left <$> do getActivity (Left (actor, obiid)) = Just . Left <$> do
obid <- getActorOutbox actor obid <- getActorOutbox actor

View file

@ -1,6 +1,6 @@
{- This file is part of Vervis. {- This file is part of Vervis.
- -
- Written in 2019, 2020 by fr33domlover <fr33domlover@riseup.net>. - Written in 2019, 2020, 2022 by fr33domlover <fr33domlover@riseup.net>.
- -
- Copying is an act of love. Please copy, reuse and share. - 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 msig <- checkForward $ LocalActorRepo shrRecip rpRecip
let mfwd = (localRecips,) <$> msig let mfwd = (localRecips,) <$> msig
case activitySpecific $ actbActivity body of 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) -> AddActivity (AP.Add obj target) ->
case obj of case obj of
Right (AddBundle patches) -> Right (AddBundle patches) ->

View file

@ -1,6 +1,6 @@
{- This file is part of Vervis. {- This file is part of Vervis.
- -
- Written in 2019, 2020 by fr33domlover <fr33domlover@riseup.net>. - Written in 2019, 2020, 2021, 2022 by fr33domlover <fr33domlover@riseup.net>.
- -
- Copying is an act of love. Please copy, reuse and share. - Copying is an act of love. Please copy, reuse and share.
- -
@ -25,6 +25,8 @@ module Vervis.Federation.Ticket
, sharerAddBundleF , sharerAddBundleF
, repoAddBundleF , repoAddBundleF
, repoApplyF
, sharerOfferDepF , sharerOfferDepF
, projectOfferDepF , projectOfferDepF
, repoOfferDepF , repoOfferDepF
@ -35,6 +37,7 @@ module Vervis.Federation.Ticket
) )
where where
import Control.Applicative
import Control.Exception hiding (Handler) import Control.Exception hiding (Handler)
import Control.Monad import Control.Monad
import Control.Monad.Logger.CallStack import Control.Monad.Logger.CallStack
@ -58,15 +61,19 @@ import Data.Time.Clock
import Data.Traversable import Data.Traversable
import Database.Persist import Database.Persist
import Database.Persist.Sql import Database.Persist.Sql
import System.Exit
import System.Process.Typed
import Text.Blaze.Html (preEscapedToHtml) import Text.Blaze.Html (preEscapedToHtml)
import Text.Blaze.Html.Renderer.Text import Text.Blaze.Html.Renderer.Text
import Yesod.Core hiding (logError, logWarn, logInfo, logDebug) import Yesod.Core hiding (logError, logWarn, logInfo, logDebug)
import Yesod.Core.Handler import Yesod.Core.Handler
import Yesod.Persist.Core import Yesod.Persist.Core
import qualified Data.ByteString.Lazy as BL
import qualified Data.List.NonEmpty as NE import qualified Data.List.NonEmpty as NE
import qualified Data.List.Ordered as LO import qualified Data.List.Ordered as LO
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy as TL
import Database.Persist.JSON import Database.Persist.JSON
@ -84,6 +91,10 @@ import Data.Tuple.Local
import Database.Persist.Local import Database.Persist.Local
import Yesod.Persist.Local import Yesod.Persist.Local
import qualified Data.Text.UTF8.Local as TU
import Development.PatchMediaType
import Vervis.ActivityPub import Vervis.ActivityPub
import Vervis.ActivityPub.Recipient import Vervis.ActivityPub.Recipient
import Vervis.FedURI import Vervis.FedURI
@ -92,12 +103,37 @@ import Vervis.Federation.Util
import Vervis.Foundation import Vervis.Foundation
import Vervis.Model import Vervis.Model
import Vervis.Model.Ident import Vervis.Model.Ident
import Development.PatchMediaType import Vervis.Model.Role
import Vervis.Model.Ticket import Vervis.Model.Ticket
import Vervis.Patch import Vervis.Patch
import Vervis.Path
import Vervis.Query
import Vervis.Ticket import Vervis.Ticket
import Vervis.WorkItem 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 checkOfferTicket
:: RemoteAuthor :: RemoteAuthor
-> AP.Ticket URIMode -> AP.Ticket URIMode
@ -163,22 +199,6 @@ checkOfferTicket author ticket uTarget = do
_ -> return () _ -> return ()
return (branch, typ, diffs) return (branch, typ, diffs)
where 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 _ _) = checkBundle _ (AP.BundleHosted _ _) =
throwE "Patches specified as URIs" throwE "Patches specified as URIs"
checkBundle h (AP.BundleOffer mlocal patches) = do checkBundle h (AP.BundleOffer mlocal patches) = do
@ -626,27 +646,6 @@ checkCreateTicket author ticket muTarget = do
_ -> return () _ -> return ()
return (branch, typ, patches) return (branch, typ, patches)
where 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 _ _) = checkBundle _ (AP.BundleHosted _ _) =
throwE "Patches specified as URIs" throwE "Patches specified as URIs"
checkBundle h (AP.BundleOffer mblocal patches) = do checkBundle h (AP.BundleOffer mblocal patches) = do
@ -1427,6 +1426,325 @@ repoAddBundleF now shrRecip rpRecip author body mfwd luAdd patches uTarget = do
LocalPersonCollectionRepoProposalFollowers LocalPersonCollectionRepoProposalFollowers
shrRecip rpRecip (hashLTID ltid) 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 sharerOfferDepF
:: UTCTime :: UTCTime
-> ShrIdent -> ShrIdent

View file

@ -33,6 +33,7 @@ data ProjectOperation
| ProjOpAddTicketDep | ProjOpAddTicketDep
| ProjOpRemoveTicketDep | ProjOpRemoveTicketDep
| ProjOpPush | ProjOpPush
| ProjOpApplyPatch
deriving (Eq, Show, Read, Enum, Bounded) deriving (Eq, Show, Read, Enum, Bounded)
derivePersistField "ProjectOperation" derivePersistField "ProjectOperation"

View file

@ -42,6 +42,8 @@ module Vervis.Ticket
, askWorkItemRoute , askWorkItemRoute
, getWorkItem , getWorkItem
, parseWorkItem , parseWorkItem
, parseProposalBundle
, getRemoteTicketByURI
, checkDepAndTarget , checkDepAndTarget
) )
@ -888,6 +890,71 @@ parseWorkItem name u@(ObjURI h lu) = do
_ -> throwE $ name <> ": not a work item route" _ -> throwE $ name <> ": not a work item route"
else return $ Right u 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 checkDepAndTarget
:: (MonadSite m, SiteEnv m ~ App) :: (MonadSite m, SiteEnv m ~ App)
=> TicketDependency URIMode => TicketDependency URIMode

View file

@ -1,6 +1,6 @@
{- This file is part of Vervis. {- This file is part of Vervis.
- -
- Written in 2019, 2020, 2021 by fr33domlover <fr33domlover@riseup.net>. - Written in 2019, 2020, 2021, 2022 by fr33domlover <fr33domlover@riseup.net>.
- -
- Copying is an act of love. Please copy, reuse and share. - Copying is an act of love. Please copy, reuse and share.
- -
@ -62,6 +62,7 @@ module Web.ActivityPub
, Accept (..) , Accept (..)
, AddObject (..) , AddObject (..)
, Add (..) , Add (..)
, Apply (..)
, CreateObject (..) , CreateObject (..)
, Create (..) , Create (..)
, Follow (..) , Follow (..)
@ -163,10 +164,10 @@ as2Context :: Text
as2Context = "https://www.w3.org/ns/activitystreams" as2Context = "https://www.w3.org/ns/activitystreams"
secContext :: Text secContext :: Text
secContext = "https://w3id.org/security/v1" secContext = "https://w3id.org/security/v2"
forgeContext :: Text forgeContext :: Text
forgeContext = "https://forgefed.peers.community/ns" forgeContext = "https://forgefed.org/ns"
extContext :: Text extContext :: Text
extContext = "https://angeley.es/as2-ext" extContext = "https://angeley.es/as2-ext"
@ -1334,6 +1335,22 @@ encodeAdd h (Add obj target)
Right o -> "object" `pair` pairs (toSeries h o) Right o -> "object" `pair` pairs (toSeries h o)
<> "target" .= target <> "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) data CreateObject u = CreateNote (Note u) | CreateTicket (Ticket u)
instance ActivityPub CreateObject where instance ActivityPub CreateObject where
@ -1490,6 +1507,7 @@ encodeUndo a (Undo obj) = "object" .= obj
data SpecificActivity u data SpecificActivity u
= AcceptActivity (Accept u) = AcceptActivity (Accept u)
| AddActivity (Add u) | AddActivity (Add u)
| ApplyActivity (Apply u)
| CreateActivity (Create u) | CreateActivity (Create u)
| FollowActivity (Follow u) | FollowActivity (Follow u)
| OfferActivity (Offer u) | OfferActivity (Offer u)
@ -1523,6 +1541,7 @@ instance ActivityPub Activity where
case typ of case typ of
"Accept" -> AcceptActivity <$> parseAccept a o "Accept" -> AcceptActivity <$> parseAccept a o
"Add" -> AddActivity <$> parseAdd o a "Add" -> AddActivity <$> parseAdd o a
"Apply" -> ApplyActivity <$> parseApply o
"Create" -> CreateActivity <$> parseCreate o a actor "Create" -> CreateActivity <$> parseCreate o a actor
"Follow" -> FollowActivity <$> parseFollow o "Follow" -> FollowActivity <$> parseFollow o
"Offer" -> OfferActivity <$> parseOffer o a actor "Offer" -> OfferActivity <$> parseOffer o a actor
@ -1545,6 +1564,7 @@ instance ActivityPub Activity where
activityType :: SpecificActivity u -> Text activityType :: SpecificActivity u -> Text
activityType (AcceptActivity _) = "Accept" activityType (AcceptActivity _) = "Accept"
activityType (AddActivity _) = "Add" activityType (AddActivity _) = "Add"
activityType (ApplyActivity _) = "Apply"
activityType (CreateActivity _) = "Create" activityType (CreateActivity _) = "Create"
activityType (FollowActivity _) = "Follow" activityType (FollowActivity _) = "Follow"
activityType (OfferActivity _) = "Offer" activityType (OfferActivity _) = "Offer"
@ -1554,6 +1574,7 @@ instance ActivityPub Activity where
activityType (UndoActivity _) = "Undo" activityType (UndoActivity _) = "Undo"
encodeSpecific h _ (AcceptActivity a) = encodeAccept h a encodeSpecific h _ (AcceptActivity a) = encodeAccept h a
encodeSpecific h _ (AddActivity a) = encodeAdd h a encodeSpecific h _ (AddActivity a) = encodeAdd h a
encodeSpecific _ _ (ApplyActivity a) = encodeApply a
encodeSpecific h u (CreateActivity a) = encodeCreate h u a encodeSpecific h u (CreateActivity a) = encodeCreate h u a
encodeSpecific _ _ (FollowActivity a) = encodeFollow a encodeSpecific _ _ (FollowActivity a) = encodeFollow a
encodeSpecific h u (OfferActivity a) = encodeOffer h u a encodeSpecific h u (OfferActivity a) = encodeOffer h u a

View file

@ -12,7 +12,7 @@ packages:
# Packages to be pulled from upstream that are not in the resolver (e.g., # Packages to be pulled from upstream that are not in the resolver (e.g.,
# acme-missiles-0.3) # acme-missiles-0.3)
extra-deps: 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 commit: 2d19eea0fae58897a02372a84cc48e7696a4e288
- ./lib/darcs-lights - ./lib/darcs-lights
- ./lib/darcs-rev - ./lib/darcs-rev

View file

@ -8,8 +8,8 @@ description:
Most of the source code is in the public domain using the CC0 public domain 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 dedication, but the application as a whole has GPL dependencies, and is
released under the AGPL 3 license. released under the AGPL 3 license.
homepage: https://dev.angeley.es/s/fr33domlover/p/vervis homepage: https://dev.openheart.work/s/fr33domlover/p/vervis
bug-reports: https://dev.angeley.es/s/fr33domlover/p/vervis/t bug-reports: https://dev.openheart.work/s/fr33domlover/p/vervis/t
license: OtherLicense license: OtherLicense
license-file: COPYING license-file: COPYING
author: fr33domlover author: fr33domlover
@ -27,7 +27,7 @@ cabal-version: >=1.10
source-repository head source-repository head
type: darcs type: darcs
location: https://dev.angeley.es/s/fr33domlover/r/vervis location: https://dev.openheart.work/s/fr33domlover/r/vervis
flag dev flag dev
description: Turn on development settings, like auto-reload templates. description: Turn on development settings, like auto-reload templates.
@ -363,6 +363,7 @@ library
, transformers , transformers
-- probably should be replaced with lenses once I learn -- probably should be replaced with lenses once I learn
, tuple , tuple
, typed-process
-- For making git hooks executable, i.e. set file mode -- For making git hooks executable, i.e. set file mode
, unix , unix
-- For httpAPEither -- For httpAPEither