Handle post-receive hook, publish a Push activity

config/models

@@ -36,12 +36,14 @@ Person
     about               Text
     inbox               InboxId
     outbox              OutboxId
+    followers           FollowerSetId
 
     UniquePersonIdent ident
     UniquePersonLogin login
     UniquePersonEmail email
     UniquePersonInbox inbox
     UniquePersonOutbox outbox
+    UniquePersonFollowers followers
 
 Outbox
 
@@ -235,8 +237,12 @@ Repo
     mainBranch Text
     collabUser RoleId               Maybe
     collabAnon RoleId               Maybe
+    inbox      InboxId
+    followers  FollowerSetId
 
     UniqueRepo ident sharer
+    UniqueRepoInbox inbox
+    UniqueRepoFollowers followers
 
 Workflow
     sharer SharerId

config/routes

@@ -62,6 +62,7 @@
 /s/#ShrIdent/notifications                   NotificationsR       GET POST
 /s/#ShrIdent/outbox                          SharerOutboxR        GET POST
 /s/#ShrIdent/outbox/#OutboxItemKeyHashid     SharerOutboxItemR    GET
+/s/#ShrIdent/followers                       SharerFollowersR     GET
 
 /p                                           PeopleR              GET
 
@@ -84,6 +85,9 @@
 /s/#ShrIdent/r                               ReposR                GET POST
 /s/#ShrIdent/r/!new                          RepoNewR              GET
 /s/#ShrIdent/r/#RpIdent                      RepoR                 GET PUT DELETE POST
+/s/#ShrIdent/r/#RpIdent/inbox                RepoInboxR            GET POST
+/s/#ShrIdent/r/#RpIdent/team                 RepoTeamR             GET
+/s/#ShrIdent/r/#RpIdent/followers            RepoFollowersR        GET
 /s/#ShrIdent/r/#RpIdent/edit                 RepoEditR             GET
 /s/#ShrIdent/r/#RpIdent/s/+Texts             RepoSourceR           GET
 /s/#ShrIdent/r/#RpIdent/c                    RepoHeadChangesR      GET

migrations/2019_09_06.model

@@ -0,0 +1,10 @@
+Inbox
+
+FollowerSet
+
+Repo
+    inbox     InboxId
+    followers FollowerSetId
+
+Person
+    followers FollowerSetId

src/Vervis/API.hs

@@ -16,6 +16,7 @@
 module Vervis.API
     ( createNoteC
     , offerTicketC
+    , pushCommitsC
     , getFollowersCollection
     )
 where
@@ -691,6 +692,87 @@ offerTicketC shrUser summary audience offer@(Offer ticket uTarget) = runExceptT
                         insert_ $ InboxItemLocal ibid obiid ibiid
                     return remotes
 
+pushCommitsC
+    :: (Entity Person, Sharer)
+    -> Html
+    -> Push URIMode
+    -> ShrIdent
+    -> RpIdent
+    -> Handler (Either Text OutboxItemId)
+pushCommitsC (eperson, sharer) summary push shrRepo rpRepo = runExceptT $ do
+    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
+                    , RepoTeamR shrRepo rpRepo
+                    , RepoFollowersR shrRepo rpRepo
+                    ]
+            activity mluAct = Doc host Activity
+                { activityId       = mluAct
+                , activityActor    = encodeRouteLocal $ SharerR shrUser
+                , activitySummary  =
+                    Just $ TextHtml $ TL.toStrict $ 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 (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime)
+              )
+            ]
+    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
+        insert_ $ InboxItemLocal (repoInbox repo) obiid ibiid
+        for_ pids $ \ pid -> do
+            ibid <- personInbox <$> getJust pid
+            ibiid <- insert $ InboxItem True
+            insert_ $ InboxItemLocal ibid obiid ibiid
+        return remotes
+
 getFollowersCollection
     :: Route App -> AppDB FollowerSetId -> Handler TypedContent
 getFollowersCollection here getFsid = do
@@ -725,4 +807,4 @@ getFollowersCollection here getFsid = do
                 map (encodeRouteHome . SharerR) locals ++
                 map (uncurry ObjURI . bimap E.unValue E.unValue) remotes
             }
-    provideHtmlAndAP followersAP $ redirect (here, [("prettyjson", "true")])
+    provideHtmlAndAP followersAP $ redirectToPrettyJSON here

src/Vervis/ActivityPub.hs

@@ -24,6 +24,7 @@ module Vervis.ActivityPub
     , getPersonOrGroupId
     , getTicketTeam
     , getProjectTeam
+    , getRepoTeam
     , getFollowers
     , unionRemotes
     , insertMany'
@@ -211,6 +212,8 @@ getTicketTeam sid = do
 
 getProjectTeam = getTicketTeam
 
+getRepoTeam = getTicketTeam
+
 getFollowers :: FollowerSetId -> AppDB ([PersonId], [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))])
 getFollowers fsid = do
     local <- selectList [FollowTarget ==. fsid] [Asc FollowPerson]

src/Vervis/Federation.hs

@@ -16,6 +16,7 @@
 module Vervis.Federation
     ( handleSharerInbox
     , handleProjectInbox
+    , handleRepoInbox
     , fixRunningDeliveries
     , retryOutboxDelivery
     )
@@ -253,6 +254,28 @@ handleProjectInbox now shrRecip prjRecip auth body = do
             projectOfferTicketF now shrRecip prjRecip remoteAuthor body offer
         _ -> return "Unsupported activity type"
 
+handleRepoInbox
+    :: UTCTime
+    -> ShrIdent
+    -> RpIdent
+    -> ActivityAuthentication
+    -> ActivityBody
+    -> ExceptT Text Handler Text
+handleRepoInbox now shrRecip rpRecip auth body = do
+    remoteAuthor <-
+        case auth of
+            ActivityAuthLocalPerson pid ->
+                throwE $
+                    "Repo inbox got local forwarded activity by pid#" <>
+                    T.pack (show $ fromSqlKey pid)
+            ActivityAuthLocalProject jid ->
+                throwE $
+                    "Repo inbox got local forwarded activity by jid#" <>
+                    T.pack (show $ fromSqlKey jid)
+            ActivityAuthRemote ra -> return ra
+    case activitySpecific $ actbActivity body of
+        _ -> return "Unsupported activity type"
+
 fixRunningDeliveries :: (MonadIO m, MonadLogger m, IsSqlBackend backend) => ReaderT backend m ()
 fixRunningDeliveries = do
     c <- updateWhereCount [UnlinkedDeliveryRunning ==. True] [UnlinkedDeliveryRunning =. False]

src/Vervis/Federation/Auth.hs

@@ -320,13 +320,39 @@ verifyForwardedSig hAuthor luAuthor (Verification malgo keyid input signature) =
     mkauth (Left pid)  = ActivityAuthLocalPerson pid
     mkauth (Right jid) = ActivityAuthLocalProject jid
 
+verifyContentTypeAP :: MonadHandler m => m ()
+verifyContentTypeAP = do
+    result <- runExceptT verifyContentTypeAP_E
+    case result of
+        Left e -> invalidArgs ["Content type error: " <> e]
+        Right () -> return ()
+
+verifyContentTypeAP_E :: MonadHandler m => ExceptT Text m ()
+verifyContentTypeAP_E = do
+    ctypes <- lookupHeaders "Content-Type"
+    case ctypes of
+        [] -> throwE "Content-Type not specified"
+        [x] | x == typeAS -> return ()
+            | x == typeAS2 -> return ()
+            | otherwise ->
+                throwE $ "Not a recognized AP Content-Type: " <>
+                    case decodeUtf8' x of
+                        Left _ -> T.pack (show x)
+                        Right t -> t
+        _ -> throwE "More than one Content-Type specified"
+    where
+    typeAS = "application/activity+json"
+    typeAS2 =
+        "application/ld+json; \
+        \profile=\"https://www.w3.org/ns/activitystreams\""
+
 authenticateActivity
     :: UTCTime
     -- -> ExceptT Text Handler (Either PersonId ActivityDetail, BL.ByteString, Object, Activity)
     -> ExceptT Text Handler (ActivityAuthentication, ActivityBody)
 authenticateActivity now = do
     (ra, wv, body) <- do
-        verifyContentType
+        verifyContentTypeAP_E
         proof <- withExceptT (T.pack . displayException) $ ExceptT $ do
             timeLimit <- getsYesod $ appHttpSigTimeLimit . appSettings
             let requires = [hRequestTarget, hHost, hDigest]
@@ -371,23 +397,6 @@ authenticateActivity now = do
                     Just a -> return a
     return (auth, ActivityBody body raw activity)
     where
-    verifyContentType = do
-        ctypes <- lookupHeaders "Content-Type"
-        case ctypes of
-            [] -> throwE "Content-Type not specified"
-            [x] | x == typeAS -> return ()
-                | x == typeAS2 -> return ()
-                | otherwise ->
-                    throwE $ "Not a recognized AP Content-Type: " <>
-                        case decodeUtf8' x of
-                            Left _ -> T.pack (show x)
-                            Right t -> t
-            _ -> throwE "More than one Content-Type specified"
-        where
-        typeAS = "application/activity+json"
-        typeAS2 =
-            "application/ld+json; \
-            \profile=\"https://www.w3.org/ns/activitystreams\""
     verifyBodyDigest = do
         req <- waiRequest
         let headers = W.requestHeaders req

src/Vervis/Form/Repo.hs

@@ -99,6 +99,8 @@ editRepoAForm sid (Entity rid repo) = Repo
         )
     <*> aopt selectRole "User role"  (Just $ repoCollabUser repo)
     <*> aopt selectRole "Guest role" (Just $ repoCollabAnon repo)
+    <*> pure (repoInbox repo)
+    <*> pure (repoFollowers repo)
     where
     selectProject' = selectProjectForExisting (repoSharer repo) rid
     selectRole =

src/Vervis/Foundation.hs

@@ -604,6 +604,7 @@ instance AccountDB AccountPersistDB' where
             Right sid -> do
                 ibid <- insert Inbox
                 obid <- insert Outbox
+                fsid <- insert FollowerSet
                 let defTime = UTCTime (ModifiedJulianDay 0) 0
                     person = Person
                         { personIdent               = sid
@@ -618,6 +619,7 @@ instance AccountDB AccountPersistDB' where
                         , personAbout               = ""
                         , personInbox               = ibid
                         , personOutbox              = obid
+                        , personFollowers           = fsid
                         }
                 pid <- insert person
                 return $ Right $ Entity pid person
@@ -738,6 +740,8 @@ instance YesodBreadcrumbs App where
         SharerOutboxItemR shr hid        -> ( "#" <> keyHashidText hid
                                             , Just $ SharerOutboxR shr
                                             )
+        SharerFollowersR shr             -> ("Followers", Just $ SharerR shr)
+
         ActorKey1R                       -> ("Actor Key 1", Nothing)
         ActorKey2R                       -> ("Actor Key 2", Nothing)
 

src/Vervis/Handler/Inbox.hs

@@ -17,8 +17,10 @@ module Vervis.Handler.Inbox
     ( getInboxR
     , getSharerInboxR
     , getProjectInboxR
+    , getRepoInboxR
     , postSharerInboxR
     , postProjectInboxR
+    , postRepoInboxR
     , getPublishR
     , getSharerOutboxR
     , getSharerOutboxItemR
@@ -283,6 +285,15 @@ getProjectInboxR shr prj = getInbox here getInboxId
         j <- getValBy404 $ UniqueProject prj sid
         return $ projectInbox j
 
+getRepoInboxR :: ShrIdent -> RpIdent -> Handler TypedContent
+getRepoInboxR shr rp = getInbox here getInboxId
+    where
+    here = RepoInboxR shr rp
+    getInboxId = do
+        sid <- getKeyBy404 $ UniqueSharer shr
+        r <- getValBy404 $ UniqueRepo rp sid
+        return $ repoInbox r
+
 postSharerInboxR :: ShrIdent -> Handler ()
 postSharerInboxR shrRecip = do
     federation <- getsYesod $ appFederation . appSettings
@@ -326,6 +337,21 @@ postProjectInboxR shrRecip prjRecip = do
         Left _ -> sendResponseStatus badRequest400 ()
         Right _ -> return ()
 
+postRepoInboxR :: ShrIdent -> RpIdent -> Handler ()
+postRepoInboxR shrRecip rpRecip = do
+    federation <- getsYesod $ appFederation . appSettings
+    unless federation badMethod
+    contentTypes <- lookupHeaders "Content-Type"
+    now <- liftIO getCurrentTime
+    result <- runExceptT $ do
+        (auth, body) <- authenticateActivity now
+        (actbObject body,) <$>
+            handleRepoInbox now shrRecip rpRecip auth body
+    recordActivity now result contentTypes
+    case result of
+        Left _ -> sendResponseStatus badRequest400 ()
+        Right _ -> return ()
+
 {-
 jsonField :: (FromJSON a, ToJSON a) => Field Handler a
 jsonField = checkMMap fromTextarea toTextarea textareaField

src/Vervis/Handler/Person.hs

@@ -137,7 +137,7 @@ getPerson shr sharer person = do
             , actorSummary    = Nothing
             , actorInbox      = encodeRouteLocal $ SharerInboxR shr
             , actorOutbox     = Just $ encodeRouteLocal $ SharerOutboxR shr
-            , actorFollowers  = Nothing
+            , actorFollowers  = Just $ encodeRouteLocal $ SharerFollowersR shr
             , actorPublicKeys =
                 [ Left $ encodeRouteLocal ActorKey1R
                 , Left $ encodeRouteLocal ActorKey2R

src/Vervis/Handler/Repo.hs

@@ -34,14 +34,18 @@ module Vervis.Handler.Repo
     , deleteRepoDevR
     , postRepoDevR
     , getDarcsDownloadR
+    , getRepoTeamR
+    , getRepoFollowersR
 
     , getHighlightStyleR
     , postPostReceiveR
     )
 where
 
+import Control.Exception hiding (Handler)
 import Control.Monad.IO.Class (liftIO)
 import Control.Monad.Logger (logWarn)
+import Data.Bifunctor
 import Data.Git.Graph
 import Data.Git.Harder
 import Data.Git.Named (RefName (..))
@@ -49,16 +53,16 @@ import Data.Git.Ref (toHex)
 import Data.Git.Repository
 import Data.Git.Storage (withRepo)
 import Data.Git.Storage.Object (Object (..))
-import Data.Git.Types (Blob (..), Commit (..), Person (..), entName)
+import Data.Git.Types (Blob (..), Person (..), entName)
 import Data.Graph.Inductive.Graph (noNodes)
 import Data.Graph.Inductive.Query.Topsort
 import Data.List (inits)
 import Data.Text (Text, unpack)
-import Data.Text.Encoding (decodeUtf8With)
+import Data.Text.Encoding
 import Data.Text.Encoding.Error (lenientDecode)
 import Data.Traversable (for)
-import Database.Esqueleto hiding (delete, (%))
+import Database.Persist
-import Database.Persist (delete)
+import Database.Persist.Sql
 import Data.Hourglass (timeConvert)
 import Formatting (sformat, stext, (%))
 import System.Directory
@@ -73,45 +77,62 @@ import Yesod.Form.Functions (runFormPost)
 import Yesod.Form.Types (FormResult (..))
 import Yesod.Persist.Core (runDB, getBy404)
 
+import qualified Data.ByteString.Lazy as BL (ByteString)
 import qualified Data.CaseInsensitive as CI (foldedCase)
 import qualified Data.DList as D
 import qualified Data.Set as S (member)
+import qualified Data.Text as T
 import qualified Data.Text.Lazy.Encoding as L (decodeUtf8With)
+import qualified Database.Esqueleto as E
+
+import Data.MediaType
+import Web.ActivityPub hiding (Repo)
+import Yesod.ActivityPub
+import Yesod.FedURI
+import Yesod.Hashids
+import Yesod.MonadSite
+import Yesod.RenderSource
+
+import qualified Web.ActivityPub as AP
 
 import Data.ByteString.Char8.Local (takeLine)
+import Data.Either.Local
 import Data.Git.Local
+import Database.Persist.Local
 import Text.FilePath.Local (breakExt)
+import Yesod.Persist.Local
+
+import qualified Data.Git.Local as G (createRepo)
+import qualified Darcs.Local.Repository as D (createRepo)
+
+import Vervis.API
 import Vervis.Form.Repo
 import Vervis.Foundation
 import Vervis.Handler.Repo.Darcs
 import Vervis.Handler.Repo.Git
 import Vervis.Path
-import Data.MediaType
 import Vervis.Model
 import Vervis.Model.Ident
 import Vervis.Model.Repo
 import Vervis.Paginate
 import Vervis.Readme
-import Yesod.RenderSource
 import Vervis.Settings
 import Vervis.SourceTree
 import Vervis.Style
 import Vervis.Widget.Repo
 import Vervis.Widget.Sharer
 
-import qualified Darcs.Local.Repository as D (createRepo)
-import qualified Data.ByteString.Lazy as BL (ByteString)
-import qualified Data.Git.Local as G (createRepo)
 import qualified Vervis.Formatting as F
+import qualified Vervis.Hook as H
 
 getReposR :: ShrIdent -> Handler Html
 getReposR user = do
-    repos <- runDB $ select $ from $ \ (sharer, repo) -> do
+    repos <- runDB $ E.select $ E.from $ \ (sharer, repo) -> do
-        where_ $
+        E.where_ $
-            sharer ^. SharerIdent ==. val user &&.
+            sharer E.^. SharerIdent E.==. E.val user E.&&.
-            sharer ^. SharerId ==. repo ^. RepoSharer
+            sharer E.^. SharerId E.==. repo E.^. RepoSharer
-        orderBy [asc $ repo ^. RepoIdent]
+        E.orderBy [E.asc $ repo E.^. RepoIdent]
-        return $ repo ^. RepoIdent
+        return $ repo E.^. RepoIdent
     defaultLayout $(widgetFile "repo/list")
 
 postReposR :: ShrIdent -> Handler Html
@@ -137,6 +158,8 @@ postReposR user = do
                             (rp2text $ nrpIdent nrp)
             pid <- requireAuthId
             runDB $ do
+                ibid <- insert Inbox
+                fsid <- insert FollowerSet
                 let repo = Repo
                         { repoIdent      = nrpIdent nrp
                         , repoSharer     = sid
@@ -146,6 +169,8 @@ postReposR user = do
                         , repoMainBranch = "master"
                         , repoCollabUser = Nothing
                         , repoCollabAnon = Nothing
+                        , repoInbox      = ibid
+                        , repoFollowers  = fsid
                         }
                 rid <- insert repo
                 let collab = RepoCollab
@@ -175,14 +200,30 @@ selectRepo shar repo = do
     Entity _rid r <- getBy404 $ UniqueRepo repo sid
     return r
 
-getRepoR :: ShrIdent -> RpIdent -> Handler Html
+getRepoR :: ShrIdent -> RpIdent -> Handler TypedContent
-getRepoR shar repo = do
+getRepoR shr rp = do
-    repository <- runDB $ selectRepo shar repo
+    repo <- runDB $ selectRepo shr rp
-    case repoVcs repository of
+    encodeRouteLocal <- getEncodeRouteLocal
-        VCSDarcs -> getDarcsRepoSource repository shar repo []
+    encodeRouteHome <- getEncodeRouteHome
-        VCSGit ->
+    let repoAP = AP.Repo
-            getGitRepoSource
+            { AP.repoActor = Actor
-                repository shar repo (repoMainBranch repository) []
+                { actorId         = encodeRouteLocal $ RepoR shr rp
+                , actorType       = ActorTypeRepo
+                , actorUsername   = Nothing
+                , actorName       = Just $ rp2text rp
+                , actorSummary    = repoDesc repo
+                , actorInbox      = encodeRouteLocal $ RepoInboxR shr rp
+                , actorOutbox     = Nothing
+                , actorFollowers  =
+                    Just $ encodeRouteLocal $ RepoFollowersR shr rp
+                , actorPublicKeys = []
+                }
+            , AP.repoTeam = encodeRouteLocal $ RepoTeamR shr rp
+            }
+        dir = case repoVcs repo of
+                VCSDarcs -> []
+                VCSGit -> [repoMainBranch repo]
+    provideHtmlAndAP repoAP $ redirect $ RepoSourceR shr rp dir
 
 putRepoR :: ShrIdent -> RpIdent -> Handler Html
 putRepoR shr rp = do
@@ -293,15 +334,15 @@ getRepoDevsR shr rp = do
             Entity s _ <- getBy404 $ UniqueSharer shr
             Entity r _ <- getBy404 $ UniqueRepo rp s
             return r
-        select $ from $ \ (collab `InnerJoin`
+        E.select $ E.from $ \ (collab `E.InnerJoin`
-                           person `InnerJoin`
+                               person `E.InnerJoin`
-                           sharer `LeftOuterJoin`
+                               sharer `E.LeftOuterJoin`
-                           role) -> do
+                               role) -> do
-            on $ collab ^. RepoCollabRole     ==. role ?. RoleId
+            E.on $ collab E.^. RepoCollabRole     E.==. role E.?. RoleId
-            on $ person ^. PersonIdent        ==. sharer ^. SharerId
+            E.on $ person E.^. PersonIdent        E.==. sharer E.^. SharerId
-            on $ collab ^. RepoCollabPerson   ==. person ^. PersonId
+            E.on $ collab E.^. RepoCollabPerson   E.==. person E.^. PersonId
-            where_ $ collab ^. RepoCollabRepo ==. val rid
+            E.where_ $ collab E.^. RepoCollabRepo E.==. E.val rid
-            return (sharer, role ?. RoleIdent)
+            return (sharer, role E.?. RoleIdent)
     defaultLayout $(widgetFile "repo/collab/list")
 
 postRepoDevsR :: ShrIdent -> RpIdent -> Handler Html
@@ -377,6 +418,53 @@ postRepoDevR shr rp dev = do
         Just "DELETE" -> deleteRepoDevR shr rp dev
         _             -> notFound
 
+getRepoTeamR :: ShrIdent -> RpIdent -> Handler TypedContent
+getRepoTeamR shr rp = do
+    memberShrs <- runDB $ do
+        sid <- getKeyBy404 $ UniqueSharer shr
+        _rid <- getKeyBy404 $ UniqueRepo rp sid
+        id_ <-
+            requireEitherAlt
+                (getKeyBy $ UniquePersonIdent sid)
+                (getKeyBy $ UniqueGroup sid)
+                "Found sharer that is neither person nor group"
+                "Found sharer that is both person and group"
+        case id_ of
+            Left pid -> return [shr]
+            Right gid -> do
+                pids <-
+                    map (groupMemberPerson . entityVal) <$>
+                        selectList [GroupMemberGroup ==. gid] []
+                sids <-
+                    map (personIdent . entityVal) <$>
+                        selectList [PersonId <-. pids] []
+                map (sharerIdent . entityVal) <$>
+                    selectList [SharerId <-. sids] []
+
+    let here = RepoTeamR shr rp
+
+    encodeRouteLocal <- getEncodeRouteLocal
+    encodeRouteHome <- getEncodeRouteHome
+    let team = Collection
+            { collectionId         = encodeRouteLocal here
+            , collectionType       = CollectionTypeUnordered
+            , collectionTotalItems = Just $ length memberShrs
+            , collectionCurrent    = Nothing
+            , collectionFirst      = Nothing
+            , collectionLast       = Nothing
+            , collectionItems      = map (encodeRouteHome . SharerR) memberShrs
+            }
+    provideHtmlAndAP team $ redirectToPrettyJSON here
+
+getRepoFollowersR :: ShrIdent -> RpIdent -> Handler TypedContent
+getRepoFollowersR shr rp = getFollowersCollection here getFsid
+    where
+    here = RepoFollowersR shr rp
+    getFsid = do
+        sid <- getKeyBy404 $ UniqueSharer shr
+        r <- getValBy404 $ UniqueRepo rp sid
+        return $ repoFollowers r
+
 getHighlightStyleR :: Text -> Handler TypedContent
 getHighlightStyleR styleName =
     case lookup (unpack styleName) highlightingStyles of
@@ -384,5 +472,108 @@ getHighlightStyleR styleName =
         Just style ->
             return $ TypedContent typeCss $ toContent $ styleToCss style
 
-postPostReceiveR :: Handler ()
+postPostReceiveR :: Handler Text
-postPostReceiveR = error "TODO post-receive handler not implemented yet"
+postPostReceiveR = do
+    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
+        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}.
+            |]
+    eid <- pushCommitsC user summary pushAP shr rp
+    case eid of
+        Left e -> liftIO $ throwIO $ userError $ T.unpack e
+        Right obiid -> do
+            renderUrl <- askUrlRender
+            obikhid <- encodeKeyHashid obiid
+            return $
+                "Push activity published: " <>
+                renderUrl (SharerOutboxItemR shrUser obikhid)
+    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
+        (commitsLast, commitsFirst) <-
+            runDB $ case mlate of
+                Nothing -> (,) <$> traverse commit2ap' early <*> pure Nothing
+                Just (_omitted, late) ->
+                    (,) <$> traverse commit2ap' late
+                        <*> (Just <$> traverse commit2ap' early)
+        return
+            ( Push
+                { pushCommitsLast  = commitsLast
+                , pushCommitsFirst = commitsFirst
+                , 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
+                , pushHashBefore   = mbefore
+                , pushHashAfter    = after
+                }
+            , shr
+            , rp
+            )
+        where
+        commit2ap shr rp (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 $ RepoPatchR 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 =
+                    if T.null desc
+                        then Nothing
+                        else Just desc
+                , commitWritten     = wtime
+                , commitCommitted   = snd <$> mcommitted
+                }
+            where
+            authorByEmail (H.Author name email) = do
+                mperson <- getValBy $ UniquePersonEmail email
+                case mperson of
+                    Nothing -> return $ Left $ Author name email
+                    Just person ->
+                        Right . sharerIdent <$> getJust (personIdent person)
+    commitsText :: Maybe a -> Int -> Text
+    commitsText Nothing n =
+        if n > 1
+            then "patches"
+            else "patch"
+    commitsText (Just _) n =
+        if n > 1
+            then "commits"
+            else "commit"
+    --branchText :: ShrIdent -> RpIdent -> Maybe Text -> HtmlUrl (Route App)
+    branchText _   _  Nothing       = const mempty
+    branchText shr rp (Just branch) =
+        [hamlet|
+            , branch #
+            <a href=@{RepoBranchR shr rp branch}>#{branch}
+        |]

src/Vervis/Handler/Repo/Darcs.hs

@@ -48,7 +48,7 @@ import qualified Data.Text as T
 import qualified Data.Text.Lazy.Encoding as L (decodeUtf8With)
 
 import Data.MediaType
-import Web.ActivityPub
+import Web.ActivityPub hiding (Repo)
 import Yesod.ActivityPub
 import Yesod.FedURI
 import Yesod.RenderSource

src/Vervis/Handler/Repo/Git.hs

@@ -59,7 +59,7 @@ import qualified Data.Text as T
 import qualified Data.Text.Lazy.Encoding as L (decodeUtf8With)
 
 import Data.MediaType
-import Web.ActivityPub hiding (Commit, Author)
+import Web.ActivityPub hiding (Commit, Author, Repo)
 import Yesod.ActivityPub
 import Yesod.FedURI
 import Yesod.RenderSource

src/Vervis/Handler/Sharer.hs

@@ -16,6 +16,7 @@
 module Vervis.Handler.Sharer
     ( getSharersR
     , getSharerR
+    , getSharerFollowersR
     )
 where
 
@@ -30,6 +31,10 @@ import Yesod.Core.Content (TypedContent)
 import Yesod.Core.Handler (redirect, notFound)
 import Yesod.Persist.Core (runDB, getBy404)
 
+import Database.Persist.Local
+import Yesod.Persist.Local
+
+import Vervis.API
 import Vervis.Foundation
 import Vervis.Handler.Person
 import Vervis.Handler.Group
@@ -64,3 +69,21 @@ getSharerR shr = do
             case ent of
                 Left (Entity _ p) -> getPerson shr s p
                 Right (Entity _ g) -> getGroup shr g
+
+getSharerFollowersR :: ShrIdent -> Handler TypedContent
+getSharerFollowersR shr = getFollowersCollection here getFsid
+    where
+    here = SharerFollowersR shr
+    getFsid = do
+        sid <- getKeyBy404 $ UniqueSharer shr
+        mval <- runMaybeT
+            $   Left  <$> MaybeT (getValBy $ UniquePersonIdent sid)
+            <|> Right <$> MaybeT (getValBy $ UniqueGroup sid)
+        case mval of
+            Nothing -> do
+                $logWarn $ "Found non-person non-group sharer: " <> shr2text shr
+                notFound
+            Just val ->
+                case val of
+                    Left person -> return $ personFollowers person
+                    Right _group -> notFound

src/Vervis/Hook.hs

@@ -42,6 +42,7 @@ import Data.Git.Graph
 import Data.Git.Harder
 import Data.Graph.Inductive.Graph -- (noNodes)
 import Data.Graph.Inductive.Query.Topsort
+import Data.Int
 import Data.List.NonEmpty (NonEmpty, nonEmpty)
 import Data.Text (Text)
 import Data.Time.Clock
@@ -49,6 +50,7 @@ import Data.Time.Clock.POSIX
 import Data.Word
 import GHC.Generics
 import Network.HTTP.Client
+import Network.HTTP.Types.Header
 import System.Directory
 import System.Environment
 import System.Exit
@@ -57,6 +59,7 @@ import System.IO
 import Text.Email.Aeson.Instances ()
 import Text.Email.Validate
 import Time.Types
+import Yesod.Core.Content
 
 import qualified Data.ByteString as B
 import qualified Data.ByteString.Base16 as B16
@@ -122,9 +125,12 @@ instance ToJSON Commit
 
 data Push = Push
     { pushSecret :: Text
+    , pushUser   :: Int64
     , pushSharer :: Text
     , pushRepo   :: Text
     , pushBranch :: Maybe Text
+    , pushBefore :: Maybe Text
+    , pushAfter  :: Text
     , pushInit   :: NonEmpty Commit
     , pushLast   :: Maybe (Int, NonEmpty Commit)
     }
@@ -148,10 +154,11 @@ writeHookConfig config = do
 
 reportNewCommits :: Config -> Text -> Text -> IO ()
 reportNewCommits config sharer repo = do
+    user <- read <$> getEnv "VERVIS_SSH_USER"
     manager <- newManager defaultManagerSettings
-    withRepo "." $ loop manager
+    withRepo "." $ loop user manager
     where
-    loop manager git = do
+    loop user manager git = do
         eof <- isEOF
         unless eof $ do
             result <- runExceptT $ do
@@ -205,9 +212,12 @@ reportNewCommits config sharer repo = do
                             return (eNE, Just (middle, lNE))
                 let push = Push
                         { pushSecret = configSecret config
+                        , pushUser   = user
                         , pushSharer = sharer
                         , pushRepo   = repo
                         , pushBranch = Just branch
+                        , pushBefore = old <$ moldRef
+                        , pushAfter  = new
                         , pushInit   = early
                         , pushLast   = late
                         }
@@ -219,6 +229,7 @@ reportNewCommits config sharer repo = do
                 req <- requestFromURI $ uriFromObjURI uri
                 let req' =
                         setRequestCheckStatus $
+                        consHeader hContentType typeJson $
                         req { method      = "POST"
                             , requestBody = RequestBodyLBS $ encode push
                             }
@@ -227,10 +238,11 @@ reportNewCommits config sharer repo = do
             case result of
                 Left e -> TIO.hPutStrLn stderr $ "HOOK ERROR: " <> e
                 Right _resp -> return ()
-            loop manager git
+            loop user manager git
         where
         adaptErr :: HttpException -> Text
         adaptErr = T.pack . displayException
+        consHeader n b r = r { requestHeaders = (n, b) : requestHeaders r }
         parseRef t =
             if t == nullRef
                 then return Nothing

src/Vervis/Migration.hs

@@ -1008,6 +1008,48 @@ changes hLocal ctx =
         "summary"
       -- 129
     , addFieldPrimRequired "TicketDependency" defaultTime "created"
+      -- 130
+    , addFieldRefRequired'
+        "Repo"
+        FollowerSet130
+        (Just $ do
+            rids <- selectKeysList ([] :: [Filter Repo130]) []
+            for_ rids $ \ rid -> do
+                fsid <- insert FollowerSet130
+                update rid [Repo130Followers =. fsid]
+        )
+        "followers"
+        "FollowerSet"
+      -- 131
+    , addUnique "Repo" $ Unique "UniqueRepoFollowers" ["followers"]
+      -- 132
+    , addFieldRefRequired'
+        "Repo"
+        Inbox130
+        (Just $ do
+            rids <- selectKeysList ([] :: [Filter Repo130]) []
+            for_ rids $ \ rid -> do
+                ibid <- insert Inbox130
+                update rid [Repo130Inbox =. ibid]
+        )
+        "inbox"
+        "Inbox"
+      -- 133
+    , addUnique "Repo" $ Unique "UniqueRepoInbox" ["inbox"]
+      -- 134
+    , addFieldRefRequired'
+        "Person"
+        FollowerSet130
+        (Just $ do
+            pids <- selectKeysList ([] :: [Filter Person130]) []
+            for_ pids $ \ pid -> do
+                fsid <- insert FollowerSet130
+                update pid [Person130Followers =. fsid]
+        )
+        "followers"
+        "FollowerSet"
+      -- 135
+    , addUnique "Person" $ Unique "UniquePersonFollowers" ["followers"]
     ]
 
 migrateDB

src/Vervis/Migration/Model.hs

@@ -118,6 +118,10 @@ module Vervis.Migration.Model
     , Ticket127Generic (..)
     , TicketDependency127Generic (..)
     , TicketDependency127
+    , Inbox130Generic (..)
+    , FollowerSet130Generic (..)
+    , Repo130
+    , Person130
     )
 where
 
@@ -239,3 +243,6 @@ makeEntitiesMigration "20190624"
 
 makeEntitiesMigration "127"
     $(modelFile "migrations/2019_07_11.model")
+
+makeEntitiesMigration "130"
+    $(modelFile "migrations/2019_09_06.model")

src/Vervis/Ssh.hs

@@ -42,6 +42,7 @@ import Network.SSH.Channel
 import Network.SSH.Crypto
 import Network.SSH.Session
 import System.Directory (doesFileExist, doesDirectoryExist)
+import System.Environment
 import System.FilePath ((</>))
 import System.Process (CreateProcess (..), StdStream (..), createProcess, proc)
 
@@ -263,6 +264,8 @@ runAction repoDir _wantReply action =
             can <- canPushTo sharer repo
             if can
                 then whenGitRepoExists True repoPath $ do
+                    pid <- authId <$> askAuthDetails
+                    liftIO $ setEnv "VERVIS_SSH_USER" (show $ fromSqlKey pid)
                     execute "git-receive-pack" [repoPath]
                     return ARProcess
                 else return $ ARFail "You can't push to this repository"

src/Web/ActivityPub.hs

@@ -31,6 +31,7 @@ module Web.ActivityPub
     , Owner (..)
     , PublicKey (..)
     , Actor (..)
+    , Repo (..)
     , Project (..)
     , CollectionType (..)
     , Collection (..)
@@ -175,22 +176,25 @@ instance (ActivityPub a, UriMode u) => ToJSON (Doc a u) where
         context [t] = "@context" .= t
         context ts  = "@context" .= ts
 
-data ActorType = ActorTypePerson | ActorTypeProject | ActorTypeOther Text
+data ActorType =
+    ActorTypePerson | ActorTypeRepo | ActorTypeProject | ActorTypeOther Text
     deriving Eq
 
 instance FromJSON ActorType where
     parseJSON = withText "ActorType" $ pure . parse
         where
         parse t
-            | t == "Person"  = ActorTypePerson
+            | t == "Person"     = ActorTypePerson
-            | t == "Project" = ActorTypeProject
+            | t == "Repository" = ActorTypeRepo
-            | otherwise      = ActorTypeOther t
+            | t == "Project"    = ActorTypeProject
+            | otherwise         = ActorTypeOther t
 
 instance ToJSON ActorType where
     toJSON = error "toJSON ActorType"
     toEncoding at =
         toEncoding $ case at of
             ActorTypePerson  -> "Person"
+            ActorTypeRepo    -> "Repository"
             ActorTypeProject -> "Project"
             ActorTypeOther t -> t
 
@@ -307,6 +311,24 @@ instance ActivityPub Actor where
             <> "followers"         .=?    (ObjURI authority <$> followers)
             <> "publicKey"         `pair` encodePublicKeySet authority pkeys
 
+data Repo u = Repo
+    { repoActor :: Actor u
+    , repoTeam  :: LocalURI
+    }
+
+instance ActivityPub Repo where
+    jsonldContext _ = [as2Context, secContext, forgeContext, extContext]
+    parseObject o = do
+        (h, a) <- parseObject o
+        unless (actorType a == ActorTypeRepo) $
+            fail "Actor type isn't Repository"
+        fmap (h,) $
+            Repo a
+                <$> withAuthorityO h (o .:| "team")
+    toSeries authority (Repo actor team)
+        =  toSeries authority actor
+        <> "team" .= ObjURI authority team
+
 data Project u = Project
     { projectActor :: Actor u
     , projectTeam  :: LocalURI
@@ -1021,10 +1043,11 @@ encodeOffer authority actor (Offer obj target)
     <> "target" .= target
 
 data Push u = Push
-    { pushCommits      :: NonEmpty (Commit u)
+    { pushCommitsLast  :: NonEmpty (Commit u)
+    , pushCommitsFirst :: Maybe (NonEmpty (Commit u))
     , pushCommitsTotal :: Int
     , pushTarget       :: LocalURI
-    , pushHashBefore   :: Text
+    , pushHashBefore   :: Maybe Text
     , pushHashAfter    :: Text
     }
 
@@ -1033,23 +1056,25 @@ parsePush a o = do
     c <- o .: "object"
     Push
         <$> (traverse (withAuthorityT a . parseObject) =<< c .: "items")
+        <*> (traverse (traverse $ withAuthorityT a . parseObject) =<< c .:? "earlyItems")
         <*> c .: "totalItems"
         <*> withAuthorityO a (o .: "target")
-        <*> o .: "hashBefore"
+        <*> o .:? "hashBefore"
         <*> o .: "hashAfter"
 
 encodePush :: UriMode u => Authority u -> Push u -> Series
-encodePush a (Push commits total target before after)
+encodePush a (Push lateCommits earlyCommits total target before after)
     =  "object"     `pair` pairs
             (  "type"       .= ("OrderedCollection" :: Text)
-            <> pair
+            <> pair "items" (objectList lateCommits)
-                "items"
+            <> maybe mempty (pair "earlyItems" . objectList) earlyCommits
-                (listEncoding (pairs . toSeries a) (NE.toList commits))
             <> "totalItems" .= total
             )
     <> "target"     .= ObjURI a target
-    <> "hashBefore" .= before
+    <> "hashBefore" .=? before
     <> "hashAfter"  .= after
+    where
+    objectList items = listEncoding (pairs . toSeries a) (NE.toList items)
 
 data Reject u = Reject
     { rejectObject :: ObjURI u

templates/repo/collab/list.hamlet

@@ -16,7 +16,7 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
   <tr>
     <th>Collaborator
     <th>Role
-  $forall (Entity _sid sharer, Value mrl) <- devs
+  $forall (Entity _sid sharer, E.Value mrl) <- devs
     <tr>
       <td>^{sharerLinkW sharer}
       <td>

templates/repo/list.hamlet

@@ -15,7 +15,7 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
 <p>These are the repositories shared by #{shr2text user}.
 
 <ul>
-  $forall Value repo <- repos
+  $forall E.Value repo <- repos
     <li>
       <a href=@{RepoR user repo}>#{rp2text repo}
   <li>