Implement C2S Follow activity and add form on /publish page

config/models

@@ -240,10 +240,12 @@ Repo
     collabUser RoleId               Maybe
     collabAnon RoleId               Maybe
     inbox      InboxId
+    outbox     OutboxId
     followers  FollowerSetId
 
     UniqueRepo ident sharer
     UniqueRepoInbox inbox
+    UniqueRepoOutbox outbox
     UniqueRepoFollowers followers
 
 Workflow

config/routes

@@ -86,6 +86,8 @@
 /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/outbox                      RepoOutboxR     GET
+/s/#ShrIdent/r/#RpIdent/outbox/#OutboxItemKeyHashid RepoOutboxItemR GET
 /s/#ShrIdent/r/#RpIdent/team                 RepoTeamR             GET
 /s/#ShrIdent/r/#RpIdent/followers            RepoFollowersR        GET
 /s/#ShrIdent/r/#RpIdent/edit                 RepoEditR             GET

migrations/2019_09_10.model

@@ -0,0 +1,4 @@
+Outbox
+
+Repo
+    outbox OutboxId

src/Vervis/API.hs

@@ -15,6 +15,7 @@
 
 module Vervis.API
     ( createNoteC
+    , followC
     , offerTicketC
     , pushCommitsC
     , getFollowersCollection
@@ -282,8 +283,8 @@ createNoteC host (Note mluNote luAttrib aud muParent muContext mpublished source
                 _ -> throwE "Local context isn't a ticket route"
 
         atMostSharer :: e -> (ShrIdent, LocalSharerRelatedSet) -> ExceptT e Handler (Maybe ShrIdent)
-        atMostSharer _ (shr, LocalSharerRelatedSet s []) = return $ if localRecipSharer s then Just shr else Nothing
+        atMostSharer _ (shr, LocalSharerRelatedSet s [] []) = return $ if localRecipSharer s then Just shr else Nothing
-        atMostSharer e (_  , LocalSharerRelatedSet _ _ ) = throwE e
+        atMostSharer e (_  , LocalSharerRelatedSet _ _  _ ) = throwE e
 
         verifyTicketRecipients :: (ShrIdent, PrjIdent, Int) -> LocalRecipientSet -> ExceptT Text Handler [ShrIdent]
         verifyTicketRecipients (shr, prj, num) recips = do
@@ -439,6 +440,190 @@ createNoteC host (Note mluNote luAttrib aud muParent muContext mpublished source
             Right _gid -> throwE "Local Note addresses a local group"
     -}
 
+data Followee
+    = FolloweeSharer ShrIdent
+    | FolloweeProject ShrIdent PrjIdent
+    | FolloweeTicket ShrIdent PrjIdent Int
+    | FolloweeRepo ShrIdent RpIdent
+
+followC
+    :: ShrIdent
+    -> TextHtml
+    -> Audience URIMode
+    -> AP.Follow URIMode
+    -> Handler (Either Text OutboxItemId)
+followC shrUser summary audience follow@(AP.Follow uObject hide) = runExceptT $ do
+    (localRecips, remoteRecips) <- do
+        mrecips <- parseAudience audience
+        fromMaybeE mrecips "Follow with no recipients"
+    federation <- asksSite $ appFederation . appSettings
+    unless (federation || null remoteRecips) $
+        throwE "Federation disabled, but remote recipients specified"
+    mfollowee <- do
+        let ObjURI h luObject = uObject
+        local <- hostIsLocal h
+        if local
+            then Just <$> do
+                    route <-
+                        fromMaybeE
+                            (decodeRouteLocal luObject)
+                            "Follow object isn't a valid route"
+                    followee <-
+                        fromMaybeE
+                            (parseFollowee route)
+                            "Follow object isn't a followee route"
+                    let actor = followeeActor followee
+                    unless (actorRecips actor == localRecips) $
+                        throwE "Follow object isn't the recipient"
+                    case followee of
+                        FolloweeSharer shr | shr == shrUser ->
+                            throwE "User trying to follow themselves"
+                        _ -> return ()
+                    return (followee, actor)
+            else do
+                unless (null localRecips) $
+                    throwE "Follow object is remote but local recips listed"
+                return Nothing
+    let dont = Authority "dont-do.any-forwarding" Nothing
+    (obiidFollow, doc, remotesHttp) <- runDBExcept $ do
+        Entity pidAuthor personAuthor <- lift $ getAuthor shrUser
+        let ibidAuthor = personInbox personAuthor
+            obidAuthor = personOutbox personAuthor
+        (obiidFollow, doc, luFollow) <- lift $ insertFollowToOutbox obidAuthor
+        for_ mfollowee $ \ (followee, actorRecip) -> do
+            (fsid, ibidRecip, unread, obidRecip) <- getFollowee followee
+            lift $ do
+                deliverFollowLocal pidAuthor fsid unread obiidFollow ibidRecip
+                obiidAccept <- insertAcceptToOutbox luFollow actorRecip obidRecip
+                deliverAcceptLocal obiidAccept ibidAuthor
+        remotesHttp <- lift $ deliverRemoteDB' dont obiidFollow remoteRecips []
+        return (obiidFollow, doc, remotesHttp)
+    lift $ forkWorker "Outbox POST handler: async HTTP delivery" $ deliverRemoteHttp dont obiidFollow doc remotesHttp
+    return obiidFollow
+    where
+    parseFollowee (SharerR shr)         = Just $ FolloweeSharer shr
+    parseFollowee (ProjectR shr prj)    = Just $ FolloweeProject shr prj
+    parseFollowee (TicketR shr prj num) = Just $ FolloweeTicket shr prj num
+    parseFollowee (RepoR shr rp)        = Just $ FolloweeRepo shr rp
+    parseFollowee _                     = Nothing
+
+    followeeActor (FolloweeSharer shr)       = LocalActorSharer shr
+    followeeActor (FolloweeProject shr prj)  = LocalActorProject shr prj
+    followeeActor (FolloweeTicket shr prj _) = LocalActorProject shr prj
+    followeeActor (FolloweeRepo shr rp)      = LocalActorRepo shr rp
+
+    getAuthor shr = do
+        sid <- getKeyBy404 $ UniqueSharer shr
+        getBy404 $ UniquePersonIdent sid
+
+    getFollowee (FolloweeSharer shr) = do
+        msid <- lift $ getKeyBy $ UniqueSharer shr
+        sid <- fromMaybeE msid "Follow object: No such sharer in DB"
+        mval <- runMaybeT
+            $   Left  <$> MaybeT (lift $ getValBy $ UniquePersonIdent sid)
+            <|> Right <$> MaybeT (lift $ getValBy $ UniqueGroup sid)
+        val <-
+            fromMaybeE mval $
+                "Found non-person non-group sharer: " <> shr2text shr
+        case val of
+            Left person -> return (personFollowers person, personInbox person, True, personOutbox person)
+            Right _group -> throwE "Follow object is a group"
+    getFollowee (FolloweeProject shr prj) = do
+        mproject <- lift $ runMaybeT $ do
+            sid <- MaybeT $ getKeyBy $ UniqueSharer shr
+            MaybeT $ getValBy $ UniqueProject prj sid
+        project <- fromMaybeE mproject "Follow object: No such project in DB"
+        return (projectFollowers project, projectInbox project, False, projectOutbox project)
+    getFollowee (FolloweeTicket shr prj num) = do
+        mproject <- lift $ runMaybeT $ do
+            sid <- MaybeT $ getKeyBy $ UniqueSharer shr
+            Entity jid project <- MaybeT $ getBy $ UniqueProject prj sid
+            ticket <- MaybeT $ getValBy $ UniqueTicket jid num
+            return (ticket, project)
+        (ticket, project) <- fromMaybeE mproject "Follow object: No such ticket in DB"
+        return (ticketFollowers ticket, projectInbox project, False, projectOutbox project)
+    getFollowee (FolloweeRepo shr rp) = do
+        mrepo <- lift $ runMaybeT $ do
+            sid <- MaybeT $ getKeyBy $ UniqueSharer shr
+            MaybeT $ getValBy $ UniqueRepo rp sid
+        repo <- fromMaybeE mrepo "Follow object: No such repo in DB"
+        return (repoFollowers repo, repoInbox repo, False, repoOutbox repo)
+
+    insertFollowToOutbox obid = do
+        hLocal <- asksSite siteInstanceHost
+        encodeRouteLocal <- getEncodeRouteLocal
+        let activity mluAct = Doc hLocal Activity
+                { activityId       = mluAct
+                , activityActor    = encodeRouteLocal $ SharerR shrUser
+                , activitySummary  = Just summary
+                , activityAudience = audience
+                , activitySpecific = FollowActivity follow
+                }
+        now <- liftIO getCurrentTime
+        obiid <- insert OutboxItem
+            { outboxItemOutbox    = obid
+            , 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, luAct)
+
+    deliverFollowLocal pidAuthor fsid unread obiid ibidRecip = do
+        insert_ $ Follow pidAuthor fsid True True
+        ibiid <- insert $ InboxItem unread
+        insert_ $ InboxItemLocal ibidRecip obiid ibiid
+
+    insertAcceptToOutbox luFollow actorRecip obidRecip = do
+        now <- liftIO getCurrentTime
+        summary <-
+            TextHtml . TL.toStrict . renderHtml <$>
+                withUrlRenderer
+                    [hamlet|
+                        <p>
+                          <a href=@{SharerR shrUser}>
+                            #{shr2text shrUser}
+                          's follow request accepted by #
+                          <a href=#{renderObjURI uObject}>
+                            #{localUriPath $ objUriLocal uObject}
+                    |]
+        hLocal <- asksSite siteInstanceHost
+        encodeRouteLocal <- getEncodeRouteLocal
+        encodeRouteHome <- getEncodeRouteHome
+        let recips = [encodeRouteHome $ SharerR shrUser]
+            accept mluAct = Doc hLocal Activity
+                { activityId       = mluAct
+                , activityActor    = objUriLocal uObject
+                , activitySummary  = Just summary
+                , activityAudience = Audience recips [] [] [] [] []
+                , activitySpecific = AcceptActivity Accept
+                    { acceptObject = ObjURI hLocal luFollow
+                    , acceptResult = Nothing
+                    }
+                }
+        obiid <- insert OutboxItem
+            { outboxItemOutbox    = obidRecip
+            , outboxItemActivity  =
+                persistJSONObjectFromDoc $ accept Nothing
+            , outboxItemPublished = now
+            }
+        obikhid <- encodeKeyHashid obiid
+        let luAct = encodeRouteLocal $ actorOutboxItem actorRecip obikhid
+            doc = accept $ Just luAct
+        update obiid [OutboxItemActivity =. persistJSONObjectFromDoc doc]
+        return obiid
+        where
+        actorOutboxItem (LocalActorSharer shr)      = SharerOutboxItemR shr
+        actorOutboxItem (LocalActorProject shr prj) = ProjectOutboxItemR shr prj
+        actorOutboxItem (LocalActorRepo shr rp)     = RepoOutboxItemR shr rp
+
+    deliverAcceptLocal obiidAccept ibidAuthor = do
+        ibiid <- insert $ InboxItem True
+        insert_ $ InboxItemLocal ibidAuthor obiidAccept ibiid
+
 offerTicketC
     :: ShrIdent
     -> TextHtml
@@ -498,7 +683,7 @@ offerTicketC shrUser summary audience offer@(Offer ticket uTarget) = runExceptT
                 else verifyOnlySharer lsrSet
             where
             offerRecips prj = LocalSharerRelatedSet
-                { localRecipSharerDirect   = LocalSharerDirectSet False
+                { localRecipSharerDirect   = LocalSharerDirectSet False False
                 , localRecipProjectRelated =
                     [ ( prj
                       , LocalProjectRelatedSet
@@ -508,10 +693,13 @@ offerTicketC shrUser summary audience offer@(Offer ticket uTarget) = runExceptT
                             }
                       )
                     ]
+                , localRecipRepoRelated    = []
                 }
-        verifyOnlySharer lsrSet =
+        verifyOnlySharer lsrSet = do
             unless (null $ localRecipProjectRelated lsrSet) $
                 throwE "Unexpected recipients unrelated to offer target"
+            unless (null $ localRecipRepoRelated lsrSet) $
+                throwE "Unexpected recipients unrelated to offer target"
     insertToOutbox now obid = do
         hLocal <- asksSite siteInstanceHost
         let activity mluAct = Doc hLocal Activity
@@ -534,7 +722,7 @@ offerTicketC shrUser summary audience offer@(Offer ticket uTarget) = runExceptT
         update obiid [OutboxItemActivity =. persistJSONObjectFromDoc doc]
         return (obiid, doc, luAct)
     deliverLocal pidAuthor shrProject prjProject now mprojAndDeps obiid luOffer recips = do
-        (pids, remotes) <- forCollect recips $ \ (shr, LocalSharerRelatedSet sharer projects) -> do
+        (pids, remotes) <- forCollect recips $ \ (shr, LocalSharerRelatedSet sharer projects _) -> do
             (pids, remotes) <-
                 traverseCollect (uncurry $ deliverLocalProject shr) projects
             pids' <- do
@@ -629,7 +817,8 @@ offerTicketC shrUser summary audience offer@(Offer ticket uTarget) = runExceptT
                             , activitySpecific = AcceptActivity Accept
                                 { acceptObject = ObjURI hLocal luOffer
                                 , acceptResult =
-                                    encodeRouteLocal $ TicketR shrProject prjProject num
+                                    Just $ encodeRouteLocal $
+                                        TicketR shrProject prjProject num
                                 }
                             }
                     obiid <- insert OutboxItem

src/Vervis/API/Recipient.hs

@@ -14,13 +14,15 @@
  -}
 
 module Vervis.API.Recipient
-    ( LocalTicketDirectSet (..)
+    ( LocalActor (..)
+    , LocalTicketDirectSet (..)
     , LocalProjectDirectSet (..)
     , LocalProjectRelatedSet (..)
     , LocalSharerDirectSet (..)
     , LocalSharerRelatedSet (..)
     , LocalRecipientSet
     , parseAudience
+    , actorRecips
     )
 where
 
@@ -32,6 +34,7 @@ import Data.Either
 import Data.Foldable
 import Data.List ((\\))
 import Data.List.NonEmpty (NonEmpty, nonEmpty)
+import Data.Maybe
 import Data.Text (Text)
 import Data.Traversable
 
@@ -62,20 +65,27 @@ import Vervis.Model.Ident
 data LocalActor
     = LocalActorSharer ShrIdent
     | LocalActorProject ShrIdent PrjIdent
+    | LocalActorRepo ShrIdent RpIdent
 
 parseLocalActor :: Route App -> Maybe LocalActor
 parseLocalActor (SharerR shr)      = Just $ LocalActorSharer shr
 parseLocalActor (ProjectR shr prj) = Just $ LocalActorProject shr prj
+parseLocalActor (RepoR shr rp)     = Just $ LocalActorRepo shr rp
 parseLocalActor _                  = Nothing
 
 data LocalPersonCollection
-    = LocalPersonCollectionProjectTeam ShrIdent PrjIdent
+    = LocalPersonCollectionSharerFollowers ShrIdent
+    | LocalPersonCollectionProjectTeam ShrIdent PrjIdent
     | LocalPersonCollectionProjectFollowers ShrIdent PrjIdent
     | LocalPersonCollectionTicketTeam ShrIdent PrjIdent Int
     | LocalPersonCollectionTicketFollowers ShrIdent PrjIdent Int
+    | LocalPersonCollectionRepoTeam ShrIdent RpIdent
+    | LocalPersonCollectionRepoFollowers ShrIdent RpIdent
 
 parseLocalPersonCollection
     :: Route App -> Maybe LocalPersonCollection
+parseLocalPersonCollection (SharerFollowersR shr) =
+    Just $ LocalPersonCollectionSharerFollowers shr
 parseLocalPersonCollection (ProjectTeamR shr prj) =
     Just $ LocalPersonCollectionProjectTeam shr prj
 parseLocalPersonCollection (ProjectFollowersR shr prj) =
@@ -84,6 +94,10 @@ parseLocalPersonCollection (TicketTeamR shr prj num) =
     Just $ LocalPersonCollectionTicketTeam shr prj num
 parseLocalPersonCollection (TicketParticipantsR shr prj num) =
     Just $ LocalPersonCollectionTicketFollowers shr prj num
+parseLocalPersonCollection (RepoTeamR shr rp) =
+    Just $ LocalPersonCollectionRepoTeam shr rp
+parseLocalPersonCollection (RepoFollowersR shr rp) =
+    Just $ LocalPersonCollectionRepoFollowers shr rp
 parseLocalPersonCollection _ = Nothing
 
 parseLocalRecipient
@@ -113,13 +127,24 @@ data LocalProjectRecipient
     | LocalTicketRelated Int LocalTicketRecipientDirect
     deriving (Eq, Ord)
 
+data LocalRepoRecipientDirect
+    = LocalRepo
+    | LocalRepoTeam
+    | LocalRepoFollowers
+    deriving (Eq, Ord)
+
+data LocalRepoRecipient = LocalRepoDirect LocalRepoRecipientDirect
+    deriving (Eq, Ord)
+
 data LocalSharerRecipientDirect
     = LocalSharer
+    | LocalSharerFollowers
     deriving (Eq, Ord)
 
 data LocalSharerRecipient
     = LocalSharerDirect LocalSharerRecipientDirect
     | LocalProjectRelated PrjIdent LocalProjectRecipient
+    | LocalRepoRelated RpIdent LocalRepoRecipient
     deriving (Eq, Ord)
 
 data LocalGroupedRecipient = LocalSharerRelated ShrIdent LocalSharerRecipient
@@ -131,9 +156,14 @@ groupedRecipientFromActor (LocalActorSharer shr) =
 groupedRecipientFromActor (LocalActorProject shr prj) =
     LocalSharerRelated shr $ LocalProjectRelated prj $
         LocalProjectDirect LocalProject
+groupedRecipientFromActor (LocalActorRepo shr rp) =
+    LocalSharerRelated shr $ LocalRepoRelated rp $ LocalRepoDirect LocalRepo
 
 groupedRecipientFromCollection
     :: LocalPersonCollection -> LocalGroupedRecipient
+groupedRecipientFromCollection
+    (LocalPersonCollectionSharerFollowers shr) =
+        LocalSharerRelated shr $ LocalSharerDirect LocalSharerFollowers
 groupedRecipientFromCollection
     (LocalPersonCollectionProjectTeam shr prj) =
         LocalSharerRelated shr $ LocalProjectRelated prj $
@@ -150,6 +180,14 @@ groupedRecipientFromCollection
     (LocalPersonCollectionTicketFollowers shr prj num) =
         LocalSharerRelated shr $ LocalProjectRelated prj $
             LocalTicketRelated num LocalTicketFollowers
+groupedRecipientFromCollection
+    (LocalPersonCollectionRepoTeam shr rp) =
+        LocalSharerRelated shr $ LocalRepoRelated rp $
+            LocalRepoDirect LocalRepoTeam
+groupedRecipientFromCollection
+    (LocalPersonCollectionRepoFollowers shr rp) =
+        LocalSharerRelated shr $ LocalRepoRelated rp $
+            LocalRepoDirect LocalRepoFollowers
 
 -------------------------------------------------------------------------------
 -- Recipient set types
@@ -179,14 +217,28 @@ data LocalProjectRelatedSet = LocalProjectRelatedSet
     }
     deriving Eq
 
+data LocalRepoDirectSet = LocalRepoDirectSet
+    { localRecipRepo          :: Bool
+    , localRecipRepoTeam      :: Bool
+    , localRecipRepoFollowers :: Bool
+    }
+    deriving Eq
+
+data LocalRepoRelatedSet = LocalRepoRelatedSet
+    { localRecipRepoDirect :: LocalRepoDirectSet
+    }
+    deriving Eq
+
 data LocalSharerDirectSet = LocalSharerDirectSet
-    { localRecipSharer :: Bool
+    { localRecipSharer          :: Bool
+    , localRecipSharerFollowers :: Bool
     }
     deriving Eq
 
 data LocalSharerRelatedSet = LocalSharerRelatedSet
     { localRecipSharerDirect   :: LocalSharerDirectSet
     , localRecipProjectRelated :: [(PrjIdent, LocalProjectRelatedSet)]
+    , localRecipRepoRelated    :: [(RpIdent, LocalRepoRelatedSet)]
     }
     deriving Eq
 
@@ -199,19 +251,24 @@ groupLocalRecipients
         (\ (LocalSharerRelated shr _) -> shr)
         (\ (LocalSharerRelated _ lsr) -> lsr)
     where
-    lsr2set = uncurry mk . partitionEithers . map lsr2e . NE.toList
+    lsr2set = mk . partitionEithers3 . map lsr2e . NE.toList
         where
         lsr2e (LocalSharerDirect d)         = Left d
-        lsr2e (LocalProjectRelated prj lpr) = Right (prj, lpr)
+        lsr2e (LocalProjectRelated prj lpr) = Right $ Left (prj, lpr)
-        mk ds ts =
+        lsr2e (LocalRepoRelated rp lrr)     = Right $ Right (rp, lrr)
+        mk (ds, ps, rs) =
             LocalSharerRelatedSet
                 (lsrs2set ds)
-                (map (second lpr2set) $ groupWithExtract fst snd ts)
+                (map (second lpr2set) $ groupWithExtract fst snd ps)
+                (map (second lrr2set) $ groupWithExtract fst snd rs)
             where
             lsrs2set = foldl' f initial
                 where
-                initial = LocalSharerDirectSet False
+                initial = LocalSharerDirectSet False False
-                f s LocalSharer = s { localRecipSharer = True }
+                f s LocalSharer =
+                    s { localRecipSharer = True }
+                f s LocalSharerFollowers =
+                    s { localRecipSharerFollowers = True }
             lpr2set = uncurry mk . partitionEithers . map lpr2e . NE.toList
                 where
                 lpr2e (LocalProjectDirect d)        = Left d
@@ -237,6 +294,16 @@ groupLocalRecipients
                             s { localRecipTicketTeam = True }
                         f s LocalTicketFollowers =
                             s { localRecipTicketFollowers = True }
+            lrr2set = LocalRepoRelatedSet . foldl' f initial . NE.map unwrap
+                where
+                unwrap (LocalRepoDirect d) = d
+                initial = LocalRepoDirectSet False False False
+                f s LocalRepo          = s { localRecipRepo = True }
+                f s LocalRepoTeam      = s { localRecipRepoTeam = True }
+                f s LocalRepoFollowers = s { localRecipRepoFollowers = True }
+        partitionEithers3 = adapt . second partitionEithers . partitionEithers
+            where
+            adapt (l1, (l2, l3)) = (l1, l2, l3)
 
 -------------------------------------------------------------------------------
 -- Parse URIs into a grouped recipient set
@@ -299,3 +366,20 @@ parseAudience audience = do
     where
     groupByHost :: [FedURI] -> [(Host, NonEmpty LocalURI)]
     groupByHost = groupAllExtract objUriAuthority objUriLocal
+
+actorIsMember :: LocalActor -> LocalRecipientSet -> Bool
+actorIsMember (LocalActorSharer shr) lrSet =
+    case lookup shr lrSet of
+        Just lsrSet -> localRecipSharer $ localRecipSharerDirect lsrSet
+        Nothing -> False
+actorIsMember (LocalActorProject shr prj) lrSet = fromMaybe False $ do
+    lsrSet <- lookup shr lrSet
+    lprSet <- lookup prj $ localRecipProjectRelated lsrSet
+    return $ localRecipProject $ localRecipProjectDirect $ lprSet
+actorIsMember (LocalActorRepo shr rp) lrSet = fromMaybe False $ do
+    lsrSet <- lookup shr lrSet
+    lrrSet <- lookup rp $ localRecipRepoRelated lsrSet
+    return $ localRecipRepo $ localRecipRepoDirect $ lrrSet
+
+actorRecips :: LocalActor -> LocalRecipientSet
+actorRecips = groupLocalRecipients . (: []) . groupedRecipientFromActor

src/Vervis/Federation/Ticket.hs

@@ -398,7 +398,8 @@ projectOfferTicketF
                                 (objUriAuthority $ remoteAuthorURI author)
                                 luOffer
                         , acceptResult =
-                            encodeRouteLocal $ TicketR shrRecip prjRecip num
+                            Just $ encodeRouteLocal $
+                                TicketR shrRecip prjRecip num
                         }
                     }
             obiid <- insert OutboxItem

src/Vervis/Form/Repo.hs

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

src/Vervis/Foundation.hs

@@ -793,6 +793,10 @@ instance YesodBreadcrumbs App where
         ReposR shar                      -> ("Repos", Just $ SharerR shar)
         RepoNewR shar                    -> ("New", Just $ ReposR shar)
         RepoR shar repo                  -> (rp2text repo, Just $ ReposR shar)
+        RepoOutboxR shr rp               -> ("Outbox", Just $ RepoR shr rp)
+        RepoOutboxItemR shr rp hid       -> ( "#" <> keyHashidText hid
+                                            , Just $ RepoOutboxR shr rp
+                                            )
         RepoEditR shr rp                 -> ("Edit", Just $ RepoR shr rp)
         RepoSourceR shar repo []         -> ("Files", Just $ RepoR shar repo)
         RepoSourceR shar repo refdir     -> ( last refdir

src/Vervis/Handler/Inbox.hs

@@ -27,6 +27,8 @@ module Vervis.Handler.Inbox
     , postSharerOutboxR
     , getProjectOutboxR
     , getProjectOutboxItemR
+    , getRepoOutboxR
+    , getRepoOutboxItemR
     , getActorKey1R
     , getActorKey2R
     , getNotificationsR
@@ -39,24 +41,15 @@ import Control.Concurrent.STM.TVar (readTVarIO, modifyTVar')
 import Control.Exception hiding (Handler)
 import Control.Monad
 import Control.Monad.IO.Class (liftIO)
-import Control.Monad.Logger.CallStack
 import Control.Monad.STM (atomically)
 import Control.Monad.Trans.Except
-import Control.Monad.Trans.Maybe
-import Crypto.Error (CryptoFailable (..))
-import Crypto.PubKey.Ed25519 (publicKey, signature, verify)
 import Data.Aeson
 import Data.Aeson.Encode.Pretty
-import Data.Bifunctor
 import Data.Bitraversable
 import Data.Foldable (for_)
-import Data.HashMap.Strict (HashMap)
 import Data.List
-import Data.List.NonEmpty (NonEmpty (..))
 import Data.Maybe
-import Data.PEM (PEM (..))
 import Data.Text (Text)
-import Data.Text.Encoding (encodeUtf8, decodeUtf8')
 import Data.Text.Lazy.Encoding (decodeUtf8)
 import Data.Time.Clock
 import Data.Time.Interval (TimeInterval, toTimeUnit)
@@ -64,18 +57,12 @@ import Data.Time.Units (Second)
 import Data.Traversable
 import Database.Persist
 import Database.Persist.Sql
-import Network.HTTP.Client (Manager, HttpException, requestFromURI)
-import Network.HTTP.Simple (httpJSONEither, getResponseBody, setRequestManager, addRequestHeader)
-import Network.HTTP.Types.Header (hDate, hHost)
 import Network.HTTP.Types.Status
 import Text.Blaze.Html (Html, preEscapedToHtml)
 import Text.Blaze.Html.Renderer.Text
 import Text.HTML.SanitizeXSS
 import Text.Shakespeare.I18N (RenderMessage)
-import UnliftIO.Exception (try)
-import Yesod.Auth (requireAuth)
 import Yesod.Core
-import Yesod.Core.Json (requireJsonBody)
 import Yesod.Core.Handler
 import Yesod.Form.Fields
 import Yesod.Form.Functions
@@ -83,20 +70,11 @@ import Yesod.Form.Types
 import Yesod.Persist.Core
 
 import qualified Data.ByteString.Char8 as BC (unpack)
-import qualified Data.ByteString.Lazy as BL
+import qualified Data.HashMap.Strict as M
-import qualified Data.CaseInsensitive as CI (mk)
-import qualified Data.HashMap.Strict as M (lookup, insert, adjust, fromList)
 import qualified Data.Text as T
 import qualified Data.Text.Lazy as TL (toStrict)
-import qualified Data.Text.Lazy.Builder as TLB
 import qualified Data.Vector as V
 import qualified Database.Esqueleto as E
-import qualified Network.Wai as W (requestMethod, rawPathInfo, requestHeaders)
-
-import Network.HTTP.Signature hiding (Algorithm (..))
-import Yesod.HttpSignature (verifyRequestSignature)
-
-import qualified Network.HTTP.Signature as S (Algorithm (..))
 
 import Database.Persist.JSON
 import Network.FedURI
@@ -107,8 +85,6 @@ import Yesod.FedURI
 import Yesod.Hashids
 import Yesod.RenderSource
 
-import qualified Data.Aeson.Encode.Pretty.ToEncoding as AEP
-
 import Data.Aeson.Local
 import Data.Either.Local
 import Data.EventTime.Local
@@ -127,8 +103,6 @@ import Vervis.Foundation
 import Vervis.Model hiding (Ticket)
 import Vervis.Model.Ident
 import Vervis.Paginate
-import Vervis.RemoteActorStore
-import Yesod.RenderSource
 import Vervis.Settings
 
 getShowTime = showTime <$> liftIO getCurrentTime
@@ -433,8 +407,20 @@ openTicketForm html = do
     deft = "Time slows down when tasting coconut ice-cream"
     defd = "Is that slow-motion effect intentional? :)"
 
-activityWidget :: ShrIdent -> Widget -> Enctype -> Widget -> Enctype -> Widget
+followForm :: Form (FedURI, FedURI)
-activityWidget shr widget1 enctype1 widget2 enctype2 =
+followForm = renderDivs $ (,)
+    <$> areq fedUriField "Target"    (Just deft)
+    <*> areq fedUriField "Recipient" (Just deft)
+    where
+    deft = ObjURI (Authority "forge.angeley.es" Nothing) $ LocalURI "/s/fr33"
+
+activityWidget
+    :: ShrIdent
+    -> Widget -> Enctype
+    -> Widget -> Enctype
+    -> Widget -> Enctype
+    -> Widget
+activityWidget shr widget1 enctype1 widget2 enctype2 widget3 enctype3 =
     [whamlet|
         <h1>Publish a ticket comment
         <form method=POST action=@{SharerOutboxR shr} enctype=#{enctype1}>
@@ -445,6 +431,11 @@ activityWidget shr widget1 enctype1 widget2 enctype2 =
         <form method=POST action=@{SharerOutboxR shr} enctype=#{enctype2}>
           ^{widget2}
           <input type=submit>
+
+        <h1>Follow a person, a projet or a repo
+        <form method=POST action=@{SharerOutboxR shr} enctype=#{enctype3}>
+          ^{widget3}
+          <input type=submit>
     |]
 
 getUserShrIdent :: Handler ShrIdent
@@ -460,7 +451,10 @@ getPublishR = do
         runFormPost $ identifyForm "f1" publishCommentForm
     ((_result2, widget2), enctype2) <-
         runFormPost $ identifyForm "f2" openTicketForm
-    defaultLayout $ activityWidget shr widget1 enctype1 widget2 enctype2
+    ((_result3, widget3), enctype3) <-
+        runFormPost $ identifyForm "f3" followForm
+    defaultLayout $
+        activityWidget shr widget1 enctype1 widget2 enctype2 widget3 enctype3
 
 getOutbox :: Route App -> AppDB OutboxId -> Handler TypedContent
 getOutbox here getObid = do
@@ -553,7 +547,12 @@ postSharerOutboxR shrAuthor = do
         runFormPost $ identifyForm "f1" publishCommentForm
     ((result2, widget2), enctype2) <-
         runFormPost $ identifyForm "f2" openTicketForm
-    let result = Left <$> result1 <|> Right <$> result2
+    ((result3, widget3), enctype3) <-
+        runFormPost $ identifyForm "f3" followForm
+    let result
+            =   Left <$> result1
+            <|> Right . Left <$> result2
+            <|> Right . Right <$> result3
 
     eid <- runExceptT $ do
         input <-
@@ -561,7 +560,7 @@ postSharerOutboxR shrAuthor = do
                 FormMissing -> throwE "Field(s) missing"
                 FormFailure _l -> throwE "Invalid input, see below"
                 FormSuccess r -> return r
-        bitraverse publishComment openTicket input
+        bitraverse publishComment (bitraverse openTicket follow) input
     case eid of
         Left err -> setMessage $ toHtml err
         Right id_ ->
@@ -571,9 +570,16 @@ postSharerOutboxR shrAuthor = do
                     renderUrl <- getUrlRender
                     let u = renderUrl $ MessageR shrAuthor lmkhid
                     setMessage $ toHtml $ "Message created! ID: " <> u
-                Right _obiid ->
+                Right (Left _obiid) ->
                     setMessage "Ticket offer published!"
-    defaultLayout $ activityWidget shrAuthor widget1 enctype1 widget2 enctype2
+                Right (Right _obiid) ->
+                    setMessage "Follow request published!"
+    defaultLayout $
+        activityWidget
+            shrAuthor
+            widget1 enctype1
+            widget2 enctype2
+            widget3 enctype3
     where
     publishComment ((hTicket, shrTicket, prj, num), muParent, msg) = do
         encodeRouteFed <- getEncodeRouteHome
@@ -656,6 +662,25 @@ postSharerOutboxR shrAuthor = do
                 , audienceNonActors = map (encodeRouteFed h) recipsC
                 }
         ExceptT $ offerTicketC shrAuthor summary audience offer
+    follow (uObject@(ObjURI hObject luObject), uRecip) = do
+        summary <-
+            TextHtml . TL.toStrict . renderHtml <$>
+                withUrlRenderer
+                    [hamlet|
+                        <p>
+                          <a href=@{SharerR shrAuthor}>
+                            #{shr2text shrAuthor}
+                          \ requested to follow #
+                            <a href=#{renderObjURI uObject}>
+                              #{renderAuthority hObject}#{localUriPath luObject}
+                          \.
+                    |]
+        let followAP = followAP
+                { followObject = uObject
+                , followHide   = False
+                }
+            audience = Audience [uRecip] [] [] [] [] []
+        ExceptT $ followC shrAuthor summary audience followAP
 
 getProjectOutboxR :: ShrIdent -> PrjIdent -> Handler TypedContent
 getProjectOutboxR shr prj = getOutbox here getObid
@@ -676,6 +701,25 @@ getProjectOutboxItemR shr prj obikhid = getOutboxItem here getObid obikhid
         j <- getValBy404 $ UniqueProject prj sid
         return $ projectOutbox j
 
+getRepoOutboxR :: ShrIdent -> RpIdent -> Handler TypedContent
+getRepoOutboxR shr rp = getOutbox here getObid
+    where
+    here = RepoOutboxR shr rp
+    getObid = do
+        sid <- getKeyBy404 $ UniqueSharer shr
+        r <- getValBy404 $ UniqueRepo rp sid
+        return $ repoOutbox r
+
+getRepoOutboxItemR
+    :: ShrIdent -> RpIdent -> KeyHashid OutboxItem -> Handler TypedContent
+getRepoOutboxItemR shr rp obikhid = getOutboxItem here getObid obikhid
+    where
+    here = RepoOutboxItemR shr rp obikhid
+    getObid = do
+        sid <- getKeyBy404 $ UniqueSharer shr
+        r <- getValBy404 $ UniqueRepo rp sid
+        return $ repoOutbox r
+
 getActorKey :: ((ActorKey, ActorKey, Bool) -> ActorKey) -> Route App -> Handler TypedContent
 getActorKey choose route = do
     actorKey <-

src/Vervis/Handler/Repo.hs

@@ -159,6 +159,7 @@ postReposR user = do
             pid <- requireAuthId
             runDB $ do
                 ibid <- insert Inbox
+                obid <- insert Outbox
                 fsid <- insert FollowerSet
                 let repo = Repo
                         { repoIdent      = nrpIdent nrp
@@ -170,6 +171,7 @@ postReposR user = do
                         , repoCollabUser = Nothing
                         , repoCollabAnon = Nothing
                         , repoInbox      = ibid
+                        , repoOutbox     = obid
                         , repoFollowers  = fsid
                         }
                 rid <- insert repo
@@ -213,10 +215,14 @@ getRepoR shr rp = do
                 , actorName       = Just $ rp2text rp
                 , actorSummary    = repoDesc repo
                 , actorInbox      = encodeRouteLocal $ RepoInboxR shr rp
-                , actorOutbox     = Nothing
+                , actorOutbox     =
+                    Just $ encodeRouteLocal $ RepoOutboxR shr rp
                 , actorFollowers  =
                     Just $ encodeRouteLocal $ RepoFollowersR shr rp
-                , actorPublicKeys = []
+                , actorPublicKeys =
+                    [ Left $ encodeRouteLocal ActorKey1R
+                    , Left $ encodeRouteLocal ActorKey2R
+                    ]
                 }
             , AP.repoTeam = encodeRouteLocal $ RepoTeamR shr rp
             }

src/Vervis/Migration.hs

@@ -941,7 +941,8 @@ changes hLocal ctx =
                         , activitySpecific = AcceptActivity Accept
                             { acceptObject = encodeRouteHome offerR
                             , acceptResult =
-                                encodeRouteLocal $ TicketR shrProject prj num
+                                Just $ encodeRouteLocal $
+                                    TicketR shrProject prj num
                             }
                         }
                 obiidNew <- insert OutboxItem20190624
@@ -1054,6 +1055,20 @@ changes hLocal ctx =
     , addFieldPrimRequired "Follow" True "public"
       -- 137
     , addFieldPrimRequired "RemoteFollow" True "public"
+      -- 138
+    , addFieldRefRequired'
+        "Repo"
+        Outbox138
+        (Just $ do
+            rids <- selectKeysList ([] :: [Filter Repo138]) []
+            for_ rids $ \ rid -> do
+                obid <- insert Outbox138
+                update rid [Repo138Outbox =. obid]
+        )
+        "outbox"
+        "Outbox"
+      -- 139
+    , addUnique "Repo" $ Unique "UniqueRepoOutbox" ["outbox"]
     ]
 
 migrateDB

src/Vervis/Migration/Model.hs

@@ -122,6 +122,8 @@ module Vervis.Migration.Model
     , FollowerSet130Generic (..)
     , Repo130
     , Person130
+    , Outbox138Generic (..)
+    , Repo138
     )
 where
 
@@ -246,3 +248,6 @@ makeEntitiesMigration "127"
 
 makeEntitiesMigration "130"
     $(modelFile "migrations/2019_09_06.model")
+
+makeEntitiesMigration "138"
+    $(modelFile "migrations/2019_09_10.model")

src/Web/ActivityPub.hs

@@ -975,19 +975,19 @@ instance ActivityPub Branch where
 
 data Accept u = Accept
     { acceptObject :: ObjURI u
-    , acceptResult :: LocalURI
+    , acceptResult :: Maybe LocalURI
     }
 
 parseAccept :: UriMode u => Authority u -> Object -> Parser (Accept u)
 parseAccept a o =
     Accept
         <$> o .: "object"
-        <*> withAuthorityO a (o .: "result")
+        <*> withAuthorityMaybeO a (o .:? "result")
 
 encodeAccept :: UriMode u => Authority u -> Accept u -> Series
-encodeAccept authority (Accept obj result)
+encodeAccept authority (Accept obj mresult)
-    =  "object" .= obj
+    =  "object" .=  obj
-    <> "result" .= ObjURI authority result
+    <> "result" .=? (ObjURI authority <$> mresult)
 
 data Create u = Create
     { createObject :: Note u