UI, S2S: Re-implement and re-enable Push activity
- When pushing to a repo, a Push activity is now automatically published - The 'actor' is now the repo, and 'attributedTo' specifies the person who pushed - No need for 'context' in the Push anymore, since it's always the 'actor' - 'target' now specifies the branch as a Branch object rather than URI (since Vervis doesn't keep AS2 objects for branches anymore) - I deleted 'pushCommitsC' (from Vervis.API) because the code for preparing and pushing an activity is so simple with the new delivery API, doesn't need a dedicated pushCommitsC function - The generated Push activity does generate an HTML summary, unlike all other generated activities (in which I removed the summary generating code); I'm still unsure whether to bring back those summaries (extra code to write, for a problematic feature that may become useless when the new UI comes)
This commit is contained in:
fr33domlover
parent
340d1eacb1
commit
934c69daae
3 changed files with 156 additions and 179 deletions
|
|
@ -31,7 +31,6 @@ module Vervis.API
|
|||
--, offerDepC
|
||||
, resolveC
|
||||
, undoC
|
||||
--, pushCommitsC
|
||||
)
|
||||
where
|
||||
|
||||
|
|
@ -3067,92 +3066,3 @@ undoC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips remo
|
|||
, AP.acceptResult = Nothing
|
||||
}
|
||||
}
|
||||
|
||||
pushCommitsC
|
||||
:: Entity Person
|
||||
-> Html
|
||||
-> Push URIMode
|
||||
-> ShrIdent
|
||||
-> RpIdent
|
||||
-> ExceptT Text Handler OutboxItemId
|
||||
pushCommitsC eperson summary push shrRepo rpRepo = do
|
||||
error "pushCommitsC temporarily disabled"
|
||||
|
||||
{-
|
||||
|
||||
|
||||
let dont = Authority "dont-do.any-forwarding" Nothing
|
||||
(obiid, doc, remotesHttp) <- runDBExcept $ do
|
||||
(obiid, doc) <- lift $ insertToOutbox
|
||||
remoteRecips <- lift $ deliverLocal obiid
|
||||
federation <- getsYesod $ appFederation . appSettings
|
||||
unless (federation || null remoteRecips) $
|
||||
throwE "Federation disabled but remote collection members found"
|
||||
remotesHttp <- lift $ deliverRemoteDB' dont obiid [] remoteRecips
|
||||
return (obiid, doc, remotesHttp)
|
||||
lift $ forkWorker "pushCommitsC: async HTTP delivery" $ deliverRemoteHttp dont obiid doc remotesHttp
|
||||
return obiid
|
||||
where
|
||||
insertToOutbox :: AppDB (OutboxItemId, Doc Activity URIMode)
|
||||
insertToOutbox = do
|
||||
host <- getsYesod siteInstanceHost
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
let shrUser = sharerIdent sharer
|
||||
aud = map encodeRouteHome
|
||||
[ SharerFollowersR shrUser
|
||||
, RepoR shrRepo rpRepo
|
||||
, RepoTeamR shrRepo rpRepo
|
||||
, RepoFollowersR shrRepo rpRepo
|
||||
]
|
||||
activity mluAct = Doc host Activity
|
||||
{ activityId = mluAct
|
||||
, activityActor = encodeRouteLocal $ SharerR shrUser
|
||||
, activityCapability = Nothing
|
||||
, activitySummary =
|
||||
Just $ renderHTML summary
|
||||
, activityAudience = Audience aud [] [] [] [] []
|
||||
, activitySpecific = PushActivity push
|
||||
}
|
||||
now <- liftIO getCurrentTime
|
||||
obiid <- insert OutboxItem
|
||||
{ outboxItemOutbox = personOutbox $ entityVal eperson
|
||||
, outboxItemActivity = persistJSONObjectFromDoc $ activity Nothing
|
||||
, outboxItemPublished = now
|
||||
}
|
||||
obikhid <- encodeKeyHashid obiid
|
||||
let luAct = encodeRouteLocal $ SharerOutboxItemR shrUser obikhid
|
||||
doc = activity $ Just luAct
|
||||
update obiid [OutboxItemActivity =. persistJSONObjectFromDoc doc]
|
||||
return (obiid, doc)
|
||||
|
||||
deliverLocal
|
||||
:: OutboxItemId
|
||||
-> AppDB
|
||||
[ ( (InstanceId, Host)
|
||||
, NonEmpty RemoteRecipient
|
||||
)
|
||||
]
|
||||
deliverLocal obiid = do
|
||||
let pidAuthor = entityKey eperson
|
||||
(sidRepo, repo) <- do
|
||||
sid <- getKeyBy404 $ UniqueSharer shrRepo
|
||||
r <- getValBy404 $ UniqueRepo rpRepo sid
|
||||
return (sid, r)
|
||||
(pids, remotes) <- do
|
||||
(repoPids, repoRemotes) <- getRepoTeam sidRepo
|
||||
(pfsPids, pfsRemotes) <-
|
||||
getFollowers $ personFollowers $ entityVal eperson
|
||||
(rfsPids, rfsRemotes) <- getFollowers $ repoFollowers repo
|
||||
return
|
||||
( L.delete pidAuthor $ union repoPids $ union pfsPids rfsPids
|
||||
, repoRemotes `unionRemotes` pfsRemotes `unionRemotes` rfsRemotes
|
||||
)
|
||||
ibiid <- insert $ InboxItem False now
|
||||
insert_ $ InboxItemLocal (repoInbox repo) obiid ibiid
|
||||
for_ pids $ \ pid -> do
|
||||
ibid <- personInbox <$> getJust pid
|
||||
ibiid <- insert $ InboxItem True now
|
||||
insert_ $ InboxItemLocal ibid obiid ibiid
|
||||
return remotes
|
||||
-}
|
||||
|
|
|
|||
|
|
@ -129,6 +129,7 @@ import qualified Data.ByteString.Lazy.Internal as BLI
|
|||
import qualified Data.CaseInsensitive as CI (foldedCase)
|
||||
import qualified Data.DList as D
|
||||
import qualified Data.Set as S (member)
|
||||
import qualified Data.Text.Encoding as TE
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Lazy.Encoding as L (decodeUtf8With)
|
||||
import qualified Database.Esqueleto as E
|
||||
|
|
@ -137,6 +138,7 @@ import Data.MediaType
|
|||
import Database.Persist.JSON
|
||||
import Development.PatchMediaType
|
||||
import Network.FedURI
|
||||
import Web.Text
|
||||
import Yesod.ActivityPub
|
||||
import Yesod.FedURI
|
||||
import Yesod.Hashids
|
||||
|
|
@ -150,6 +152,7 @@ import Data.Either.Local
|
|||
import Data.Git.Local
|
||||
import Database.Persist.Local
|
||||
import Text.FilePath.Local (breakExt)
|
||||
import Web.Hashids.Local
|
||||
import Yesod.Form.Local
|
||||
import Yesod.Persist.Local
|
||||
|
||||
|
|
@ -157,6 +160,7 @@ import qualified Data.Git.Local as G (createRepo)
|
|||
import qualified Darcs.Local.Repository as D (createRepo)
|
||||
|
||||
import Vervis.Access
|
||||
import Vervis.ActivityPub
|
||||
import Vervis.API
|
||||
import Vervis.Federation.Auth
|
||||
import Vervis.Federation.Collab
|
||||
|
|
@ -168,6 +172,7 @@ import Vervis.Path
|
|||
import Vervis.Model
|
||||
import Vervis.Model.Ident
|
||||
import Vervis.Paginate
|
||||
import Vervis.Persist.Actor
|
||||
import Vervis.Readme
|
||||
import Vervis.Recipient
|
||||
import Vervis.Settings
|
||||
|
|
@ -175,6 +180,7 @@ import Vervis.SourceTree
|
|||
import Vervis.Style
|
||||
import Vervis.Web.Actor
|
||||
import Vervis.Web.Darcs
|
||||
import Vervis.Web.Delivery
|
||||
import Vervis.Web.Git
|
||||
|
||||
import qualified Vervis.Client as C
|
||||
|
|
@ -538,111 +544,165 @@ postRepoUnfollowR :: KeyHashid Repo -> Handler ()
|
|||
postRepoUnfollowR _ = error "Temporarily disabled"
|
||||
|
||||
postPostReceiveR :: Handler Text
|
||||
postPostReceiveR = return "Temporarily disabled, no Push activity published"
|
||||
{-
|
||||
postPostReceiveR = do
|
||||
-- Parse the push object that the hook sent
|
||||
push <- requireCheckJsonBody
|
||||
(pushAP, shr, rp) <- push2ap push
|
||||
user <- runDB $ do
|
||||
p <- getJustEntity $ toSqlKey $ H.pushUser push
|
||||
s <- getJust $ personIdent $ entityVal p
|
||||
return (p, s)
|
||||
let shrUser = sharerIdent $ snd user
|
||||
summary <- do
|
||||
let mbranch = H.pushBranch push
|
||||
total = pushCommitsTotal pushAP
|
||||
lasts = pushCommitsLast pushAP
|
||||
rest firsts = total - length firsts - length lasts
|
||||
hashText (Hash b) = decodeUtf8 b
|
||||
commitW c =
|
||||
[hamlet|
|
||||
<a href=@{RepoCommitR shr rp $ hashText $ commitHash c}>
|
||||
#{commitTitle c}
|
||||
|]
|
||||
withUrlRenderer
|
||||
[hamlet|
|
||||
<p>
|
||||
<a href=@{SharerR shrUser}>#{shr2text shrUser}
|
||||
\ pushed #{total} #
|
||||
\ #{commitsText mbranch total} to repo #
|
||||
<a href=@{RepoR shr rp}>#{rp2text rp}</a>^{branchText shr rp mbranch}:
|
||||
<ul>
|
||||
$maybe firsts <- pushCommitsFirst pushAP
|
||||
$forall c <- firsts
|
||||
<li>^{commitW c}
|
||||
<li>#{rest firsts}
|
||||
$forall c <- lasts
|
||||
<li>^{commitW c}
|
||||
|]
|
||||
eid <- runExceptT $ pushCommitsC user summary pushAP shr rp
|
||||
case eid of
|
||||
|
||||
errorOrPush <- runExceptT $ do
|
||||
|
||||
-- Compose an ActivityPub Push activity
|
||||
(pushAP, repoID, repoHash) <- lift $ push2ap push
|
||||
|
||||
-- Find repo and person in DB
|
||||
let pusherID = toSqlKey $ H.pushUser push
|
||||
(Entity actorID actor, pusher) <- runDBExcept $ do
|
||||
|
||||
repoActorEntity <- do
|
||||
repo <- getE repoID "Repo not found in DB"
|
||||
lift $ getJustEntity $ repoActor repo
|
||||
|
||||
person <- getE pusherID "Pusher person not found in DB"
|
||||
let actorID = personActor person
|
||||
actor <- lift $ getJust actorID
|
||||
let pusher = (Entity pusherID person, actor)
|
||||
|
||||
return (repoActorEntity, pusher)
|
||||
|
||||
-- Compose summary and audience
|
||||
let repoName = actorName actor
|
||||
summary <-
|
||||
lift $ renderHTML <$> makeSummary push pushAP repoHash repoName pusher
|
||||
let audience = [AudLocal [] [LocalStageRepoFollowers repoHash]]
|
||||
(localRecips, remoteRecips, fwdHosts, action) <-
|
||||
lift $ C.makeServerInput Nothing (Just summary) audience (AP.PushActivity pushAP)
|
||||
|
||||
-- Publish and deliver Push activity
|
||||
now <- liftIO getCurrentTime
|
||||
runDBExcept $ do
|
||||
pushID <- lift $ insertEmptyOutboxItem (actorOutbox actor) now
|
||||
luPush <- lift $ updateOutboxItem (LocalActorRepo repoID) pushID action
|
||||
deliverHttpPush <-
|
||||
deliverActivityDB
|
||||
(LocalActorRepo repoHash) actorID localRecips remoteRecips
|
||||
fwdHosts pushID action
|
||||
return (luPush, deliverHttpPush)
|
||||
|
||||
-- HTTP delivery to remote recipients
|
||||
case errorOrPush of
|
||||
Left e -> liftIO $ throwIO $ userError $ T.unpack e
|
||||
Right obiid -> do
|
||||
renderUrl <- askUrlRender
|
||||
obikhid <- encodeKeyHashid obiid
|
||||
Right (luPush, deliverHttpPush) -> do
|
||||
forkWorker "PostReceiveR: async HTTP Push delivery" deliverHttpPush
|
||||
hLocal <- asksSite siteInstanceHost
|
||||
return $
|
||||
"Push activity published: " <>
|
||||
renderUrl (SharerOutboxItemR shrUser obikhid)
|
||||
renderObjURI (ObjURI hLocal luPush)
|
||||
|
||||
where
|
||||
push2ap (H.Push secret _ sharer repo mbranch mbefore after early mlate) = do
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
let shr = text2shr sharer
|
||||
rp = text2rp repo
|
||||
commit2ap' = commit2ap shr rp
|
||||
|
||||
push2ap (H.Push secret personNum repo mbranch mbefore after early mlate) = do
|
||||
secret' <- asksSite appHookSecret
|
||||
unless (secret == H.hookSecretText secret') $
|
||||
error "Inavlid hook secret"
|
||||
repoID <- do
|
||||
ctx <- asksSite siteHashidsContext
|
||||
case decodeInt64 ctx $ TE.encodeUtf8 repo of
|
||||
Nothing -> error "Invalid repo keyhashid"
|
||||
Just repoNum -> return $ toSqlKey repoNum
|
||||
repoHash <- do
|
||||
repoHash <- encodeKeyHashid repoID
|
||||
unless (keyHashidText repoHash == repo) $
|
||||
error "decode-encode repo hash returned a different value"
|
||||
return repoHash
|
||||
let commit2ap' = commit2ap repoHash
|
||||
(commitsLast, commitsFirst) <-
|
||||
runDB $ case mlate of
|
||||
Nothing -> (,) <$> traverse commit2ap' early <*> pure Nothing
|
||||
Just (_omitted, late) ->
|
||||
(,) <$> traverse commit2ap' late
|
||||
<*> (Just <$> traverse commit2ap' early)
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
let pusherID = toSqlKey personNum
|
||||
pusherHash <- encodeKeyHashid pusherID
|
||||
let luRepo = encodeRouteLocal $ RepoR repoHash
|
||||
return
|
||||
( Push
|
||||
{ pushCommitsLast = commitsLast
|
||||
, pushCommitsFirst = commitsFirst
|
||||
, pushCommitsTotal =
|
||||
( AP.Push
|
||||
{ AP.pushCommitsLast = commitsLast
|
||||
, AP.pushCommitsFirst = commitsFirst
|
||||
, AP.pushCommitsTotal =
|
||||
case mlate of
|
||||
Nothing -> length early
|
||||
Just (omitted, late) ->
|
||||
length early + omitted + length late
|
||||
, pushTarget =
|
||||
encodeRouteLocal $
|
||||
case mbranch of
|
||||
Nothing -> RepoR shr rp
|
||||
Just b -> RepoBranchR shr rp b
|
||||
, pushContext = encodeRouteLocal $ RepoR shr rp
|
||||
, pushHashBefore = mbefore
|
||||
, pushHashAfter = after
|
||||
, AP.pushTarget =
|
||||
case mbranch of
|
||||
Nothing -> Left luRepo
|
||||
Just b ->
|
||||
Right $ AP.Branch b ("refs/heads/" <> b) luRepo
|
||||
, AP.pushAttrib = encodeRouteHome $ PersonR pusherHash
|
||||
, AP.pushHashBefore = mbefore
|
||||
, AP.pushHashAfter = after
|
||||
}
|
||||
, shr
|
||||
, rp
|
||||
, repoID
|
||||
, repoHash
|
||||
)
|
||||
where
|
||||
commit2ap shr rp (H.Commit (wauthor, wtime) mcommitted hash title desc) = do
|
||||
commit2ap repoHash (H.Commit (wauthor, wtime) mcommitted hash title desc) = do
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
author <- authorByEmail wauthor
|
||||
mcommitter <- traverse (authorByEmail . fst) mcommitted
|
||||
return Commit
|
||||
{ commitId = encodeRouteLocal $ RepoCommitR shr rp hash
|
||||
, commitRepository = encodeRouteLocal $ RepoR shr rp
|
||||
, commitAuthor = second (encodeRouteHome . SharerR) author
|
||||
, commitCommitter =
|
||||
second (encodeRouteHome . SharerR) <$> mcommitter
|
||||
, commitTitle = title
|
||||
, commitHash = Hash $ encodeUtf8 hash
|
||||
, commitDescription =
|
||||
return AP.Commit
|
||||
{ AP.commitId = encodeRouteLocal $ RepoCommitR repoHash hash
|
||||
, AP.commitRepository = encodeRouteLocal $ RepoR repoHash
|
||||
, AP.commitAuthor = second (encodeRouteHome . PersonR) author
|
||||
, AP.commitCommitter =
|
||||
second (encodeRouteHome . PersonR) <$> mcommitter
|
||||
, AP.commitTitle = title
|
||||
, AP.commitHash = AP.Hash $ TE.encodeUtf8 hash
|
||||
, AP.commitDescription =
|
||||
if T.null desc
|
||||
then Nothing
|
||||
else Just desc
|
||||
, commitWritten = wtime
|
||||
, commitCommitted = snd <$> mcommitted
|
||||
, AP.commitWritten = wtime
|
||||
, AP.commitCommitted = snd <$> mcommitted
|
||||
}
|
||||
where
|
||||
authorByEmail (H.Author name email) = do
|
||||
mperson <- getValBy $ UniquePersonEmail email
|
||||
mperson <- getKeyBy $ UniquePersonEmail email
|
||||
case mperson of
|
||||
Nothing -> return $ Left $ Author name email
|
||||
Just person ->
|
||||
Right . sharerIdent <$> getJust (personIdent person)
|
||||
Nothing -> return $ Left $ AP.Author name email
|
||||
Just person -> Right <$> encodeKeyHashid person
|
||||
|
||||
makeSummary push pushAP repoHash repoName (Entity personID person, actor) = do
|
||||
let mbranch = H.pushBranch push
|
||||
total = AP.pushCommitsTotal pushAP
|
||||
lasts = AP.pushCommitsLast pushAP
|
||||
rest firsts = total - length firsts - length lasts
|
||||
hashText (AP.Hash b) = decodeUtf8 b
|
||||
commitW c =
|
||||
[hamlet|
|
||||
<a href=@{RepoCommitR repoHash $ hashText $ AP.commitHash c}>
|
||||
#{AP.commitTitle c}
|
||||
|]
|
||||
personHash <- encodeKeyHashid personID
|
||||
withUrlRenderer
|
||||
[hamlet|
|
||||
<p>
|
||||
<a href=@{PersonR personHash}>
|
||||
#{actorName actor} ~#{username2text $ personUsername person}
|
||||
\ pushed #{total} #
|
||||
\ #{commitsText mbranch total} to repo #
|
||||
<a href=@{RepoR repoHash}>^#{keyHashidText repoHash} #{repoName}</a>^{branchText repoHash mbranch}:
|
||||
<ul>
|
||||
$maybe firsts <- AP.pushCommitsFirst pushAP
|
||||
$forall c <- firsts
|
||||
<li>^{commitW c}
|
||||
<li>#{rest firsts}
|
||||
$forall c <- lasts
|
||||
<li>^{commitW c}
|
||||
|]
|
||||
|
||||
commitsText :: Maybe a -> Int -> Text
|
||||
commitsText Nothing n =
|
||||
if n > 1
|
||||
|
|
@ -652,14 +712,14 @@ postPostReceiveR = return "Temporarily disabled, no Push activity published"
|
|||
if n > 1
|
||||
then "commits"
|
||||
else "commit"
|
||||
|
||||
--branchText :: ShrIdent -> RpIdent -> Maybe Text -> HtmlUrl (Route App)
|
||||
branchText _ _ Nothing = const mempty
|
||||
branchText shr rp (Just branch) =
|
||||
branchText _ Nothing = const mempty
|
||||
branchText r (Just branch) =
|
||||
[hamlet|
|
||||
, branch #
|
||||
<a href=@{RepoBranchR shr rp branch}>#{branch}
|
||||
<a href=@{RepoBranchCommitsR r branch}>#{branch}
|
||||
|]
|
||||
-}
|
||||
|
||||
postRepoLinkR :: KeyHashid Repo -> KeyHashid Loom -> Handler Html
|
||||
postRepoLinkR repoHash loomHash = do
|
||||
|
|
|
|||
|
|
@ -1610,8 +1610,8 @@ data Push u = Push
|
|||
{ pushCommitsLast :: NonEmpty (Commit u)
|
||||
, pushCommitsFirst :: Maybe (NonEmpty (Commit u))
|
||||
, pushCommitsTotal :: Int
|
||||
, pushTarget :: LocalURI
|
||||
, pushContext :: LocalURI
|
||||
, pushTarget :: Either LocalURI (Branch u)
|
||||
, pushAttrib :: ObjURI u
|
||||
, pushHashBefore :: Maybe Text
|
||||
, pushHashAfter :: Maybe Text
|
||||
}
|
||||
|
|
@ -1623,23 +1623,30 @@ parsePush a o = do
|
|||
<$> (traverse (withAuthorityT a . parseObject) =<< c .: "items" <|> c .: "orderedItems")
|
||||
<*> (traverse (traverse $ withAuthorityT a . parseObject) =<< c .:? "earlyItems")
|
||||
<*> c .: "totalItems"
|
||||
<*> withAuthorityO a (o .: "target")
|
||||
<*> withAuthorityO a (o .: "context")
|
||||
<*> (do target <- o .:+ "target"
|
||||
let (h, target') =
|
||||
case target of
|
||||
Left (ObjURI h lu) -> (h, Left lu)
|
||||
Right (Doc h branch) -> (h, Right branch)
|
||||
unless (h == a) $ fail "target host != Push host"
|
||||
return target'
|
||||
)
|
||||
<*> o .: "attributedTo"
|
||||
<*> o .:? "hashBefore"
|
||||
<*> o .:? "hashAfter"
|
||||
|
||||
encodePush :: UriMode u => Authority u -> Push u -> Series
|
||||
encodePush a (Push lateCommits earlyCommits total target context before after)
|
||||
= "object" `pair` pairs
|
||||
encodePush a (Push lateCommits earlyCommits total target attrib before after)
|
||||
= "object" `pair` pairs
|
||||
( "type" .= ("OrderedCollection" :: Text)
|
||||
<> pair "orderedItems" (objectList lateCommits)
|
||||
<> maybe mempty (pair "earlyItems" . objectList) earlyCommits
|
||||
<> "totalItems" .= total
|
||||
)
|
||||
<> "target" .= ObjURI a target
|
||||
<> "context" .= ObjURI a context
|
||||
<> "hashBefore" .=? before
|
||||
<> "hashAfter" .=? after
|
||||
<> "target" .=+ bimap (ObjURI a) (Doc a) target
|
||||
<> "attributedTo" .= attrib
|
||||
<> "hashBefore" .=? before
|
||||
<> "hashAfter" .=? after
|
||||
where
|
||||
objectList items = listEncoding (pairs . toSeries a) (NE.toList items)
|
||||
|
||||
|
|
|
|||
Loading…
Reference in a new issue