From 934c69daae0f9c633d8bb41e0620e3332377c572 Mon Sep 17 00:00:00 2001
From: fr33domlover <fr33domlover@riseup.net>
Date: Wed, 26 Oct 2022 10:47:38 +0000
Subject: [PATCH] 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)
---
 src/Vervis/API.hs          |  90 ---------------
 src/Vervis/Handler/Repo.hs | 218 +++++++++++++++++++++++--------------
 src/Web/ActivityPub.hs     |  27 +++--
 3 files changed, 156 insertions(+), 179 deletions(-)

diff --git a/src/Vervis/API.hs b/src/Vervis/API.hs
index 50321c9..523d061 100644
--- a/src/Vervis/API.hs
+++ b/src/Vervis/API.hs
@@ -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
--}
diff --git a/src/Vervis/Handler/Repo.hs b/src/Vervis/Handler/Repo.hs
index 8891cbb..19a65d0 100644
--- a/src/Vervis/Handler/Repo.hs
+++ b/src/Vervis/Handler/Repo.hs
@@ -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
diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs
index b355269..938be7d 100644
--- a/src/Web/ActivityPub.hs
+++ b/src/Web/ActivityPub.hs
@@ -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)