Implement remote following, disable automatic following

This patch contains migrations that require that there are no follow records.
If you have any, the migration will (hopefully) fail and you'll need to
manually delete any follow records you have. In the next patch I'll try to add
automatic following on the pseudo-client side by running both e.g. createNoteC
and followC in the same POST request handler.

config/models

@@ -149,6 +149,28 @@ RemoteCollection
 
     UniqueRemoteCollection instance ident
 
+FollowRemoteRequest
+    person   PersonId
+    target   FedURI
+    recip    FedURI Maybe
+    public   Bool
+    activity OutboxItemId
+
+    UniqueFollowRemoteRequest person target
+    UniqueFollowRemoteRequestActivity activity
+
+FollowRemote
+    person PersonId
+    recip  RemoteActorId -- actor managing the followed object
+    target FedURI        -- the followed object
+    public Bool
+    follow OutboxItemId
+    accept RemoteActivityId
+
+    UniqueFollowRemote person target
+    UniqueFollowRemoteFollow follow
+    UniqueFollowRemoteAccept accept
+
 FollowerSet
 
 Follow
@@ -156,16 +178,24 @@ Follow
     target FollowerSetId
     manual Bool
     public Bool
+    follow OutboxItemId
+    accept OutboxItemId
 
     UniqueFollow person target
+    UniqueFollowFollow follow
+    UniqueFollowAccept accept
 
 RemoteFollow
     actor  RemoteActorId
     target FollowerSetId
     manual Bool
     public Bool
+    follow RemoteActivityId
+    accept OutboxItemId
 
     UniqueRemoteFollow actor target
+    UniqueRemoteFollowFollow follow
+    UniqueRemoteFollowAccept accept
 
 SshKey
     ident   KyIdent

config/routes

@@ -63,6 +63,7 @@
 /s/#ShrIdent/outbox                          SharerOutboxR        GET POST
 /s/#ShrIdent/outbox/#OutboxItemKeyHashid     SharerOutboxItemR    GET
 /s/#ShrIdent/followers                       SharerFollowersR     GET
+/s/#ShrIdent/follow                          SharerFollowR        POST
 
 /p                                           PeopleR              GET
 
@@ -91,6 +92,7 @@
 /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/follow               RepoFollowR           POST
 /s/#ShrIdent/r/#RpIdent/s/+Texts             RepoSourceR           GET
 /s/#ShrIdent/r/#RpIdent/c                    RepoHeadChangesR      GET
 /s/#ShrIdent/r/#RpIdent/b/#Text              RepoBranchR           GET
@@ -114,6 +116,7 @@
 /s/#ShrIdent/p/#PrjIdent/team                ProjectTeamR          GET
 /s/#ShrIdent/p/#PrjIdent/followers           ProjectFollowersR     GET
 /s/#ShrIdent/p/#PrjIdent/edit                ProjectEditR          GET
+/s/#ShrIdent/p/#PrjIdent/follow              ProjectFollowR        POST
 /s/#ShrIdent/p/#PrjIdent/d                   ProjectDevsR          GET POST
 /s/#ShrIdent/p/#PrjIdent/d/!new              ProjectDevNewR        GET
 /s/#ShrIdent/p/#PrjIdent/d/#ShrIdent         ProjectDevR           GET DELETE POST
@@ -149,6 +152,7 @@
 /s/#ShrIdent/p/#PrjIdent/t/#Int/unclaim      TicketUnclaimR        POST
 /s/#ShrIdent/p/#PrjIdent/t/#Int/assign       TicketAssignR         GET POST
 /s/#ShrIdent/p/#PrjIdent/t/#Int/unassign     TicketUnassignR       POST
+/s/#ShrIdent/p/#PrjIdent/t/#Int/follow       TicketFollowR         POST
 /s/#ShrIdent/p/#PrjIdent/tcr                 ClaimRequestsProjectR GET
 /s/#ShrIdent/p/#PrjIdent/t/#Int/cr           ClaimRequestsTicketR  GET POST
 /s/#ShrIdent/p/#PrjIdent/t/#Int/cr/new       ClaimRequestNewR      GET

migrations/2019_09_25.model

@@ -0,0 +1,21 @@
+FollowRemoteRequest
+    person   PersonId
+    target   FedURI
+    recip    FedURI Maybe
+    public   Bool
+    activity OutboxItemId
+
+    UniqueFollowRemoteRequest person target
+    UniqueFollowRemoteRequestActivity activity
+
+FollowRemote
+    person PersonId
+    recip  RemoteActorId -- actor managing the followed object
+    target FedURI        -- the followed object
+    public Bool
+    follow OutboxItemId
+    accept RemoteActivityId
+
+    UniqueFollowRemote person target
+    UniqueFollowRemoteFollow follow
+    UniqueFollowRemoteAccept accept

src/Vervis/API.hs

@@ -182,7 +182,7 @@ createNoteC host (Note mluNote luAttrib aud muParent muContext mpublished source
                             unless (messageRoot m == did) $
                                 throwE "Remote parent belongs to a different discussion"
                             return mid
-                lift $ insertUnique_ $ Follow pid (ticketFollowers t) False True
+                -- lift $ insertUnique_ $ Follow pid (ticketFollowers t) False True
                 return (did, Left <$> mmidParent, Just (sid, ticketFollowers t, ibidProject, fsidProject))
             Nothing -> do
                 (rd, rdnew) <- lift $ do
@@ -452,7 +452,7 @@ followC
     -> Audience URIMode
     -> AP.Follow URIMode
     -> Handler (Either Text OutboxItemId)
-followC shrUser summary audience follow@(AP.Follow uObject hide) = runExceptT $ do
+followC shrUser summary audience follow@(AP.Follow uObject muContext hide) = runExceptT $ do
     (localRecips, remoteRecips) <- do
         mrecips <- parseAudience audience
         fromMaybeE mrecips "Follow with no recipients"
@@ -490,11 +490,13 @@ followC shrUser summary audience follow@(AP.Follow uObject hide) = runExceptT $
         let ibidAuthor = personInbox personAuthor
             obidAuthor = personOutbox personAuthor
         (obiidFollow, doc, luFollow) <- lift $ insertFollowToOutbox obidAuthor
-        for_ mfollowee $ \ (followee, actorRecip) -> do
+        case mfollowee of
+            Nothing -> lift $ insert_ $ FollowRemoteRequest pidAuthor uObject muContext (not hide) obiidFollow
+            Just (followee, actorRecip) -> do
                 (fsid, ibidRecip, unread, obidRecip) <- getFollowee followee
                 lift $ do
-                deliverFollowLocal pidAuthor fsid unread obiidFollow ibidRecip
                     obiidAccept <- insertAcceptToOutbox luFollow actorRecip obidRecip
+                    deliverFollowLocal pidAuthor fsid unread obiidFollow obiidAccept ibidRecip
                     deliverAcceptLocal obiidAccept ibidAuthor
         remotesHttp <- lift $ deliverRemoteDB' dont obiidFollow remoteRecips []
         return (obiidFollow, doc, remotesHttp)
@@ -572,10 +574,10 @@ followC shrUser summary audience follow@(AP.Follow uObject hide) = runExceptT $
         update obiid [OutboxItemActivity =. persistJSONObjectFromDoc doc]
         return (obiid, doc, luAct)
 
-    deliverFollowLocal pidAuthor fsid unread obiid ibidRecip = do
+    deliverFollowLocal pidAuthor fsid unread obiidF obiidA ibidRecip = do
-        insert_ $ Follow pidAuthor fsid True (not hide)
+        insert_ $ Follow pidAuthor fsid True (not hide) obiidF obiidA
         ibiid <- insert $ InboxItem unread
-        insert_ $ InboxItemLocal ibidRecip obiid ibiid
+        insert_ $ InboxItemLocal ibidRecip obiidF ibiid
 
     insertAcceptToOutbox luFollow actorRecip obidRecip = do
         now <- liftIO getCurrentTime
@@ -854,13 +856,13 @@ offerTicketC shrUser summary audience offer@(Offer ticket uTarget) = runExceptT
                     , ticketFollowers   = fsid
                     , ticketAccept      = obiidAccept
                     }
-                insert TicketAuthorLocal
+                insert_ TicketAuthorLocal
                     { ticketAuthorLocalTicket = tid
                     , ticketAuthorLocalAuthor = pidAuthor
                     , ticketAuthorLocalOffer  = obiid
                     }
                 --insertMany_ $ map (TicketDependency tid) tidsDeps
-                insert_ $ Follow pidAuthor fsid False True
+                -- insert_ $ Follow pidAuthor fsid False True
             publishAccept pidAuthor sid jid fsid luOffer num obiid doc = do
                 now <- liftIO getCurrentTime
                 let dont = Authority "dont-do.any-forwarding" Nothing

src/Vervis/Application.hs

@@ -83,6 +83,7 @@ import Vervis.RemoteActorStore
 
 -- Import all relevant handler modules here.
 -- Don't forget to add new modules to your cabal file!
+import Vervis.Handler.Client
 import Vervis.Handler.Common
 import Vervis.Handler.Git
 import Vervis.Handler.Group

src/Vervis/Client.hs

@@ -0,0 +1,99 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2019 by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ Copying is an act of love. Please copy, reuse and share.
+ -
+ - The author(s) have dedicated all copyright and related and neighboring
+ - rights to this software to the public domain worldwide. This software is
+ - distributed without any warranty.
+ -
+ - You should have received a copy of the CC0 Public Domain Dedication along
+ - with this software. If not, see
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+module Vervis.Client
+    ( follow
+    , followSharer
+    , followProject
+    , followTicket
+    , followRepo
+    )
+where
+
+import Text.Blaze.Html.Renderer.Text
+import Text.Hamlet
+import Yesod.Core
+import Yesod.Core.Handler
+
+import qualified Data.Text.Lazy as TL
+
+import Network.FedURI
+import Web.ActivityPub
+import Yesod.FedURI
+import Yesod.MonadSite
+
+import Vervis.FedURI
+import Vervis.Foundation
+import Vervis.Model.Ident
+
+follow
+    :: (MonadHandler m, HandlerSite m ~ App)
+    => ShrIdent -> ObjURI URIMode -> ObjURI URIMode -> Bool -> m (TextHtml, Audience URIMode, Follow URIMode)
+follow shrAuthor uObject@(ObjURI hObject luObject) uRecip hide = 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 = Follow
+            { followObject  = uObject
+            , followContext =
+                if uObject == uRecip
+                    then Nothing
+                    else Just uRecip
+            , followHide    = hide
+            }
+        audience = Audience [uRecip] [] [] [] [] []
+    return (summary, audience, followAP)
+
+followSharer
+    :: (MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App)
+    => ShrIdent -> ShrIdent -> Bool -> m (TextHtml, Audience URIMode, Follow URIMode)
+followSharer shrAuthor shrObject hide = do
+    encodeRouteHome <- getEncodeRouteHome
+    let uObject = encodeRouteHome $ SharerR shrObject
+    follow shrAuthor uObject uObject hide
+
+followProject
+    :: (MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App)
+    => ShrIdent -> ShrIdent -> PrjIdent -> Bool -> m (TextHtml, Audience URIMode, Follow URIMode)
+followProject shrAuthor shrObject prjObject hide = do
+    encodeRouteHome <- getEncodeRouteHome
+    let uObject = encodeRouteHome $ ProjectR shrObject prjObject
+    follow shrAuthor uObject uObject hide
+
+followTicket
+    :: (MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App)
+    => ShrIdent -> ShrIdent -> PrjIdent -> Int -> Bool -> m (TextHtml, Audience URIMode, Follow URIMode)
+followTicket shrAuthor shrObject prjObject numObject hide = do
+    encodeRouteHome <- getEncodeRouteHome
+    let uObject = encodeRouteHome $ TicketR shrObject prjObject numObject
+        uRecip = encodeRouteHome $ ProjectR shrObject prjObject
+    follow shrAuthor uObject uRecip hide
+
+followRepo
+    :: (MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App)
+    => ShrIdent -> ShrIdent -> RpIdent -> Bool -> m (TextHtml, Audience URIMode, Follow URIMode)
+followRepo shrAuthor shrObject rpObject hide = do
+    encodeRouteHome <- getEncodeRouteHome
+    let uObject = encodeRouteHome $ RepoR shrObject rpObject
+    follow shrAuthor uObject uObject hide

src/Vervis/Federation/Discussion.hs

@@ -318,7 +318,7 @@ projectCreateNoteF now shrRecip prjRecip author body (Note mluNote _ _ muParent
                 delete mid
                 return Nothing
             Just _ -> do
-                insertUnique_ $ RemoteFollow raidAuthor fsid False True
+                -- insertUnique_ $ RemoteFollow raidAuthor fsid False True
                 ibiid <- insert $ InboxItem False
                 insert_ $ InboxItemRemote ibid ractid ibiid
                 return $ Just (ractid, mid)

src/Vervis/Federation/Offer.hs

@@ -29,6 +29,7 @@ import Control.Monad
 import Control.Monad.Logger.CallStack
 import Control.Monad.Trans.Class
 import Control.Monad.Trans.Except
+import Control.Monad.Trans.Maybe
 import Data.Aeson
 import Data.Bifunctor
 import Data.Foldable
@@ -75,20 +76,32 @@ import Vervis.Model
 import Vervis.Model.Ident
 import Vervis.Model.Ticket
 
-acceptF
+sharerAcceptF
-    :: AppDB InboxId
+    :: ShrIdent
-    -> Route App
     -> UTCTime
     -> RemoteAuthor
     -> ActivityBody
     -> Accept URIMode
     -> ExceptT Text Handler Text
-acceptF getIbid route now author body (Accept _uOffer _luTicket) = do
+sharerAcceptF shr now author body (Accept (ObjURI hOffer luOffer) _) = do
     luAccept <-
         fromMaybeE (activityId $ actbActivity body) "Accept without 'id'"
     lift $ runDB $ do
-        ibidRecip <- getIbid
+        Entity pidRecip recip <- do
-        insertToInbox luAccept ibidRecip
+            sid <- getKeyBy404 $ UniqueSharer shr
+            getBy404 $ UniquePersonIdent sid
+        mractid <- insertToInbox luAccept $ personInbox recip
+        encodeRouteLocal <- getEncodeRouteLocal
+        let me = localUriPath $ encodeRouteLocal $ SharerR shr
+        case mractid of
+            Nothing -> return $ "Activity already exists in inbox of " <> me
+            Just ractid -> do
+                mv <- insertFollow pidRecip (personOutbox recip) ractid
+                case mv of
+                    Nothing ->
+                        return $ "Activity inserted to inbox of " <> me
+                    Just () ->
+                        return $ "Accept received for follow request by " <> me
     where
     insertToInbox luAccept ibidRecip = do
         let iidAuthor = remoteAuthorInstance author
@@ -98,76 +111,64 @@ acceptF getIbid route now author body (Accept _uOffer _luTicket) = do
         ibiid <- insert $ InboxItem True
         mibrid <- insertUnique $ InboxItemRemote ibidRecip ractid ibiid
         encodeRouteLocal <- getEncodeRouteLocal
-        let recip = localUriPath $ encodeRouteLocal route
         case mibrid of
             Nothing -> do
                 delete ibiid
-                return $ "Activity already exists in inbox of " <> recip
+                return Nothing
-            Just _ -> return $ "Activity inserted to inbox of " <> recip
+            Just _ -> return $ Just ractid
+    insertFollow pidRecip obidRecip ractidAccept = runMaybeT $ do
+        guard =<< hostIsLocal hOffer
+        route <- MaybeT . pure $ decodeRouteLocal luOffer
+        obiid <-
+            case route of
+                SharerOutboxItemR shr' obikhid
+                    | shr == shr' -> decodeKeyHashidM obikhid
+                _ -> MaybeT $ pure Nothing
+        obi <- MaybeT $ get obiid
+        guard $ outboxItemOutbox obi == obidRecip
+        Entity frrid frr <- MaybeT $ getBy $ UniqueFollowRemoteRequestActivity obiid
+        guard $ followRemoteRequestPerson frr == pidRecip
+        let originalRecip =
+                case followRemoteRequestRecip frr of
+                    Nothing -> followRemoteRequestTarget frr
+                    Just u -> u
+        guard $ originalRecip == remoteAuthorURI author
+        lift $ delete frrid
+        lift $ insert_ FollowRemote
+            { followRemotePerson = pidRecip
+            , followRemoteRecip  = remoteAuthorId author
+            , followRemoteTarget = followRemoteRequestTarget frr
+            , followRemotePublic = followRemoteRequestPublic frr
+            , followRemoteFollow = followRemoteRequestActivity frr
+            , followRemoteAccept = ractidAccept
+            }
 
-sharerAcceptF
+sharerRejectF
     :: ShrIdent
     -> UTCTime
     -> RemoteAuthor
     -> ActivityBody
-    -> Accept URIMode
-    -> ExceptT Text Handler Text
-sharerAcceptF shr = acceptF getIbid route
-    where
-    route = SharerR shr
-    getIbid = do
-            sid <- getKeyBy404 $ UniqueSharer shr
-            p <- getValBy404 $ UniquePersonIdent sid
-            return $ personInbox p
-
-{-
-projectAcceptF
-    :: ShrIdent
-    -> PrjIdent
-    -> UTCTime
-    -> RemoteAuthor
-    -> ActivityBody
-    -> Accept URIMode
-    -> ExceptT Text Handler Text
-projectAcceptF shr prj = acceptF getIbid route
-    where
-    route = ProjectR shr prj
-    getIbid = do
-            sid <- getKeyBy404 $ UniqueSharer shr
-            j <- getValBy404 $ UniqueProject prj sid
-            return $ projectInbox j
-
-repoAcceptF
-    :: ShrIdent
-    -> RpIdent
-    -> UTCTime
-    -> RemoteAuthor
-    -> ActivityBody
-    -> Accept URIMode
-    -> ExceptT Text Handler Text
-repoAcceptF shr rp = acceptF getIbid route
-    where
-    route = RepoR shr rp
-    getIbid = do
-            sid <- getKeyBy404 $ UniqueSharer shr
-            r <- getValBy404 $ UniqueRepo rp sid
-            return $ repoInbox r
--}
-
-rejectF
-    :: AppDB InboxId
-    -> Route App
-    -> UTCTime
-    -> RemoteAuthor
-    -> ActivityBody
     -> Reject URIMode
     -> ExceptT Text Handler Text
-rejectF getIbid route now author body (Reject _uOffer) = do
+sharerRejectF shr now author body (Reject (ObjURI hOffer luOffer)) = do
     luReject <-
         fromMaybeE (activityId $ actbActivity body) "Reject without 'id'"
     lift $ runDB $ do
-        ibidRecip <- getIbid
+        Entity pidRecip recip <- do
-        insertToInbox luReject ibidRecip
+            sid <- getKeyBy404 $ UniqueSharer shr
+            getBy404 $ UniquePersonIdent sid
+        mractid <- insertToInbox luReject $ personInbox recip
+        encodeRouteLocal <- getEncodeRouteLocal
+        let me = localUriPath $ encodeRouteLocal $ SharerR shr
+        case mractid of
+            Nothing -> return $ "Activity already exists in inbox of " <> me
+            Just ractid -> do
+                mv <- deleteFollow pidRecip (personOutbox recip)
+                case mv of
+                    Nothing ->
+                        return $ "Activity inserted to inbox of " <> me
+                    Just () ->
+                        return $ "Reject received for follow request by " <> me
     where
     insertToInbox luReject ibidRecip = do
         let iidAuthor = remoteAuthorInstance author
@@ -177,61 +178,29 @@ rejectF getIbid route now author body (Reject _uOffer) = do
         ibiid <- insert $ InboxItem True
         mibrid <- insertUnique $ InboxItemRemote ibidRecip ractid ibiid
         encodeRouteLocal <- getEncodeRouteLocal
-        let recip = localUriPath $ encodeRouteLocal route
         case mibrid of
             Nothing -> do
                 delete ibiid
-                return $ "Activity already exists in inbox of " <> recip
+                return Nothing
-            Just _ -> return $ "Activity inserted to inbox of " <> recip
+            Just _ -> return $ Just ractid
-
+    deleteFollow pidRecip obidRecip = runMaybeT $ do
-sharerRejectF
+        guard =<< hostIsLocal hOffer
-    :: ShrIdent
+        route <- MaybeT . pure $ decodeRouteLocal luOffer
-    -> UTCTime
+        obiid <-
-    -> RemoteAuthor
+            case route of
-    -> ActivityBody
+                SharerOutboxItemR shr' obikhid
-    -> Reject URIMode
+                    | shr == shr' -> decodeKeyHashidM obikhid
-    -> ExceptT Text Handler Text
+                _ -> MaybeT $ pure Nothing
-sharerRejectF shr = rejectF getIbid route
+        obi <- MaybeT $ get obiid
-    where
+        guard $ outboxItemOutbox obi == obidRecip
-    route = SharerR shr
+        Entity frrid frr <- MaybeT $ getBy $ UniqueFollowRemoteRequestActivity obiid
-    getIbid = do
+        guard $ followRemoteRequestPerson frr == pidRecip
-        sid <- getKeyBy404 $ UniqueSharer shr
+        let originalRecip =
-        p <- getValBy404 $ UniquePersonIdent sid
+                case followRemoteRequestRecip frr of
-        return $ personInbox p
+                    Nothing -> followRemoteRequestTarget frr
-
+                    Just u -> u
-{-
+        guard $ originalRecip == remoteAuthorURI author
-projectRejectF
+        lift $ delete frrid
-    :: ShrIdent
-    -> PrjIdent
-    -> UTCTime
-    -> RemoteAuthor
-    -> ActivityBody
-    -> Reject URIMode
-    -> ExceptT Text Handler Text
-projectRejectF shr prj = rejectF getIbid route
-    where
-    route = ProjectR shr prj
-    getIbid = do
-        sid <- getKeyBy404 $ UniqueSharer shr
-        j <- getValBy404 $ UniqueProject prj sid
-        return $ projectInbox j
-
-repoRejectF
-    :: ShrIdent
-    -> RpIdent
-    -> UTCTime
-    -> RemoteAuthor
-    -> ActivityBody
-    -> Reject URIMode
-    -> ExceptT Text Handler Text
-repoRejectF shr rp = rejectF getIbid route
-    where
-    route = RepoR shr rp
-    getIbid = do
-        sid <- getKeyBy404 $ UniqueSharer shr
-        r <- getValBy404 $ UniqueRepo rp sid
-        return $ repoInbox r
--}
 
 followF
     :: (Route App -> Maybe a)
@@ -248,7 +217,7 @@ followF
     -> ExceptT Text Handler Text
 followF
     objRoute recipRoute getRecip recipInbox recipOutbox recipFollowers outboxItemRoute
-    now author body (AP.Follow (ObjURI hObj luObj) hide) = do
+    now author body (AP.Follow (ObjURI hObj luObj) _mcontext hide) = do
         mobj <- do
             local <- hostIsLocal hObj
             return $
@@ -265,15 +234,16 @@ followF
                 emsg <- lift $ runDB $ do
                     recip <- getRecip obj
                     newItem <- insertToInbox luFollow $ recipInbox recip
-                    if newItem
+                    case newItem of
-                        then do
+                        Nothing -> return $ Left "Activity already exists in inbox, not using"
-                            newFollow <- insertFollow $ recipFollowers recip
+                        Just ractid -> do
-                            if newFollow
-                                then Right <$> do
                             (obiid, doc) <-
                                 insertAcceptToOutbox
                                     luFollow
                                     (recipOutbox recip)
+                            newFollow <- insertFollow ractid obiid $ recipFollowers recip
+                            if newFollow
+                                then Right <$> do
                                     let raidAuthor = remoteAuthorId author
                                     ra <- getJust raidAuthor
                                     let raInfo = (raidAuthor, remoteActorIdent ra, remoteActorInbox ra, remoteActorErrorSince ra)
@@ -281,8 +251,9 @@ followF
                                         hAuthor = objUriAuthority $ remoteAuthorURI author
                                         hostSection = ((iidAuthor, hAuthor), raInfo :| [])
                                     (obiid, doc,) <$> deliverRemoteDB' dont obiid [] [hostSection]
-                                else return $ Left "You're already a follower of me"
+                                else do
-                        else return $ Left "Activity already exists in inbox, not using"
+                                    delete obiid
+                                    return $ Left "You're already a follower of me"
                 case emsg of
                     Left msg -> return msg
                     Right (obiid, doc, remotesHttp) -> do
@@ -302,12 +273,12 @@ followF
         case mibrid of
             Nothing -> do
                 delete ibiid
-                return False
+                return Nothing
-            Just _ -> return True
+            Just _ -> return $ Just ractid
 
-    insertFollow fsid = do
+    insertFollow ractid obiidA fsid = do
         let raid = remoteAuthorId author
-        mrfid <- insertUnique $ RemoteFollow raid fsid True (not hide)
+        mrfid <- insertUnique $ RemoteFollow raid fsid True (not hide) ractid obiidA
         return $ isJust mrfid
 
     insertAcceptToOutbox luFollow obidRecip = do

src/Vervis/Federation/Ticket.hs

@@ -262,7 +262,7 @@ projectOfferTicketF
                     , ticketAuthorRemoteOffer  = ractid
                     }
                 -- insertMany_ $ map (TicketDependency tid) deps
-                insert_ $ RemoteFollow raidAuthor fsid False True
+                --insert_ $ RemoteFollow raidAuthor fsid False True
                 return $ Just (ractid, next, obiidAccept, docAccept)
 
     deliverLocal

src/Vervis/Foundation.hs

@@ -299,6 +299,7 @@ instance Yesod App where
         (SharerInboxR shr          , False) -> person shr
         (NotificationsR shr        , _   ) -> person shr
         (SharerOutboxR shr         , True) -> person shr
+        (SharerFollowR shr         , True) -> personAny
 
         (GroupsR                   , True) -> personAny
         (GroupNewR                 , _   ) -> personAny
@@ -322,6 +323,7 @@ instance Yesod App where
         (RepoNewR shr              , _   ) -> personOrGroupAdmin shr
         (RepoR shar _              , True) -> person shar
         (RepoEditR shr _rp         , _   ) -> person shr
+        (RepoFollowR _shr _rp      , True) -> personAny
         (RepoDevsR shr _rp         , _   ) -> person shr
         (RepoDevNewR shr _rp       , _   ) -> person shr
         (RepoDevR shr _rp _dev     , _   ) -> person shr
@@ -330,6 +332,7 @@ instance Yesod App where
         (ProjectNewR shr           , _   ) -> personOrGroupAdmin shr
         (ProjectR shr _prj         , True) -> person shr
         (ProjectEditR shr _prj     , _   ) -> person shr
+        (ProjectFollowR _shr _prj  , _   ) -> personAny
         (ProjectDevsR shr _prj     , _   ) -> person shr
         (ProjectDevNewR shr _prj   , _   ) -> person shr
         (ProjectDevR shr _prj _dev , _   ) -> person shr
@@ -362,6 +365,7 @@ instance Yesod App where
         (TicketUnclaimR s j _      , _   ) -> projOp ProjOpUnclaimTicket s j
         (TicketAssignR s j _       , _   ) -> projOp ProjOpAssignTicket s j
         (TicketUnassignR s j _     , _   ) -> projOp ProjOpUnassignTicket s j
+        (TicketFollowR _ _ _       , True) -> personAny
         (ClaimRequestsTicketR s j _, True) -> projOp ProjOpRequestTicket s j
         (ClaimRequestNewR s j _    , _   ) -> projOp ProjOpRequestTicket s j
         (TicketDiscussionR _ _ _   , True) -> personAny

src/Vervis/Handler/Client.hs

@@ -0,0 +1,528 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2019 by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ Copying is an act of love. Please copy, reuse and share.
+ -
+ - The author(s) have dedicated all copyright and related and neighboring
+ - rights to this software to the public domain worldwide. This software is
+ - distributed without any warranty.
+ -
+ - You should have received a copy of the CC0 Public Domain Dedication along
+ - with this software. If not, see
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+module Vervis.Handler.Client
+    ( getPublishR
+    , postSharerOutboxR
+    , postSharerFollowR
+    , postProjectFollowR
+    , postTicketFollowR
+    , postRepoFollowR
+    , getNotificationsR
+    , postNotificationsR
+    )
+where
+
+import Control.Applicative
+import Control.Exception hiding (Handler)
+import Control.Monad
+import Control.Monad.Trans.Except
+import Data.Bitraversable
+import Data.Maybe
+import Data.Text (Text)
+import Data.Time.Clock
+import Data.Traversable
+import Database.Persist
+import Text.Blaze.Html (preEscapedToHtml)
+import Text.Blaze.Html.Renderer.Text
+import Text.HTML.SanitizeXSS
+import Yesod.Core
+import Yesod.Core.Widget
+import Yesod.Form
+import Yesod.Persist.Core
+
+import qualified Data.HashMap.Strict as M
+import qualified Data.Text as T
+import qualified Data.Text.Lazy as TL
+import qualified Database.Esqueleto as E
+
+import Database.Persist.JSON
+import Network.FedURI
+import Web.ActivityPub hiding (Ticket)
+import Yesod.Auth.Unverified
+import Yesod.FedURI
+import Yesod.Hashids
+import Yesod.RenderSource
+
+import qualified Web.ActivityPub as AP
+
+import Data.Either.Local
+import Data.EventTime.Local
+import Data.Time.Clock.Local
+import Database.Persist.Local
+import Yesod.Persist.Local
+
+import Vervis.ActivityPub
+import Vervis.API
+import Vervis.Client
+import Vervis.FedURI
+import Vervis.Foundation
+import Vervis.Model
+import Vervis.Model.Ident
+import Vervis.Settings
+
+import qualified Vervis.Client as C
+
+getShowTime = showTime <$> liftIO getCurrentTime
+    where
+    showTime now =
+        showEventTime .
+        intervalToEventTime .
+        FriendlyConvert .
+        diffUTCTime now
+
+objectSummary o =
+    case M.lookup "summary" o of
+        Just (String t) | not (T.null t) -> Just t
+        _ -> Nothing
+
+objectId o =
+    case M.lookup "id" o <|> M.lookup "@id" o of
+        Just (String t) | not (T.null t) -> t
+        _ -> error "'id' field not found"
+
+fedUriField
+    :: (Monad m, RenderMessage (HandlerSite m) FormMessage) => Field m FedURI
+fedUriField = Field
+    { fieldParse = parseHelper $ \ t ->
+        case parseObjURI t of
+            Left e  -> Left $ MsgInvalidUrl $ T.pack e <> ": " <> t
+            Right u -> Right u
+    , fieldView = \theId name attrs val isReq ->
+        [whamlet|<input ##{theId} name=#{name} *{attrs} type=url :isReq:required value=#{either id renderObjURI val}>|]
+    , fieldEnctype = UrlEncoded
+    }
+
+ticketField
+    :: (Route App -> LocalURI) -> Field Handler (Host, ShrIdent, PrjIdent, Int)
+ticketField encodeRouteLocal = checkMMap toTicket fromTicket fedUriField
+    where
+    toTicket uTicket = runExceptT $ do
+        let ObjURI hTicket luTicket = uTicket
+        route <-
+            case decodeRouteLocal luTicket of
+                Nothing -> throwE ("Not a valid route" :: Text)
+                Just r -> return r
+        case route of
+            TicketR shr prj num -> return (hTicket, shr, prj, num)
+            _ -> throwE "Not a ticket route"
+    fromTicket (h, shr, prj, num) =
+        ObjURI h $ encodeRouteLocal $ TicketR shr prj num
+
+projectField
+    :: (Route App -> LocalURI) -> Field Handler (Host, ShrIdent, PrjIdent)
+projectField encodeRouteLocal = checkMMap toProject fromProject fedUriField
+    where
+    toProject u = runExceptT $ do
+        let ObjURI h lu = u
+        route <-
+            case decodeRouteLocal lu of
+                Nothing -> throwE ("Not a valid route" :: Text)
+                Just r -> return r
+        case route of
+            ProjectR shr prj -> return (h, shr, prj)
+            _ -> throwE "Not a project route"
+    fromProject (h, shr, prj) = ObjURI h $ encodeRouteLocal $ ProjectR shr prj
+
+publishCommentForm
+    :: Form ((Host, ShrIdent, PrjIdent, Int), Maybe FedURI, Text)
+publishCommentForm html = do
+    enc <- getEncodeRouteLocal
+    flip renderDivs html $ (,,)
+        <$> areq (ticketField enc) "Ticket"      (Just deft)
+        <*> aopt fedUriField       "Replying to" (Just $ Just defp)
+        <*> areq textField         "Message"     (Just defmsg)
+    where
+    deft = (Authority "forge.angeley.es" Nothing, text2shr "fr33", text2prj "sandbox", 1)
+    defp = ObjURI (Authority "forge.angeley.es" Nothing) $ LocalURI "/s/fr33/m/2f1a7"
+    defmsg = "Hi! I'm testing federation. Can you see my message? :)"
+
+openTicketForm
+    :: Form ((Host, ShrIdent, PrjIdent), TextHtml, TextPandocMarkdown)
+openTicketForm html = do
+    enc <- getEncodeRouteLocal
+    flip renderDivs html $ (,,)
+        <$> areq (projectField enc) "Project"     (Just defj)
+        <*> ( TextHtml . sanitizeBalance <$>
+              areq textField        "Title"       (Just deft)
+            )
+        <*> ( TextPandocMarkdown . T.filter (/= '\r') . unTextarea <$>
+              areq textareaField    "Description" (Just defd)
+            )
+    where
+    defj = (Authority "forge.angeley.es" Nothing, text2shr "fr33", text2prj "sandbox")
+    deft = "Time slows down when tasting coconut ice-cream"
+    defd = "Is that slow-motion effect intentional? :)"
+
+followForm :: Form (FedURI, FedURI)
+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}>
+          ^{widget1}
+          <input type=submit>
+
+        <h1>Open a new ticket
+        <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
+getUserShrIdent = do
+    Entity _ p <- requireVerifiedAuth
+    s <- runDB $ getJust $ personIdent p
+    return $ sharerIdent s
+
+getPublishR :: Handler Html
+getPublishR = do
+    shr <- getUserShrIdent
+    ((_result1, widget1), enctype1) <-
+        runFormPost $ identifyForm "f1" publishCommentForm
+    ((_result2, widget2), enctype2) <-
+        runFormPost $ identifyForm "f2" openTicketForm
+    ((_result3, widget3), enctype3) <-
+        runFormPost $ identifyForm "f3" followForm
+    defaultLayout $
+        activityWidget shr widget1 enctype1 widget2 enctype2 widget3 enctype3
+
+postSharerOutboxR :: ShrIdent -> Handler Html
+postSharerOutboxR shrAuthor = do
+    federation <- getsYesod $ appFederation . appSettings
+    unless federation badMethod
+
+    ((result1, widget1), enctype1) <-
+        runFormPost $ identifyForm "f1" publishCommentForm
+    ((result2, widget2), enctype2) <-
+        runFormPost $ identifyForm "f2" openTicketForm
+    ((result3, widget3), enctype3) <-
+        runFormPost $ identifyForm "f3" followForm
+    let result
+            =   Left <$> result1
+            <|> Right . Left <$> result2
+            <|> Right . Right <$> result3
+
+    eid <- runExceptT $ do
+        input <-
+            case result of
+                FormMissing -> throwE "Field(s) missing"
+                FormFailure _l -> throwE "Invalid input, see below"
+                FormSuccess r -> return r
+        bitraverse publishComment (bitraverse openTicket follow) input
+    case eid of
+        Left err -> setMessage $ toHtml err
+        Right id_ ->
+            case id_ of
+                Left lmid -> do
+                    lmkhid <- encodeKeyHashid lmid
+                    renderUrl <- getUrlRender
+                    let u = renderUrl $ MessageR shrAuthor lmkhid
+                    setMessage $ toHtml $ "Message created! ID: " <> u
+                Right (Left _obiid) ->
+                    setMessage "Ticket offer published!"
+                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
+        encodeRouteLocal <- getEncodeRouteLocal
+        let msg' = T.filter (/= '\r') msg
+        contentHtml <- ExceptT . pure $ renderPandocMarkdown msg'
+        let encodeRecipRoute = ObjURI hTicket . encodeRouteLocal
+            uTicket = encodeRecipRoute $ TicketR shrTicket prj num
+            ObjURI hLocal luAuthor = encodeRouteFed $ SharerR shrAuthor
+            collections =
+                [ ProjectFollowersR shrTicket prj
+                , TicketParticipantsR shrTicket prj num
+                , TicketTeamR shrTicket prj num
+                ]
+            recips = ProjectR shrTicket prj : collections
+            note = Note
+                { noteId        = Nothing
+                , noteAttrib    = luAuthor
+                , noteAudience  = Audience
+                    { audienceTo        = map encodeRecipRoute recips
+                    , audienceBto       = []
+                    , audienceCc        = []
+                    , audienceBcc       = []
+                    , audienceGeneral   = []
+                    , audienceNonActors = map encodeRecipRoute collections
+                    }
+                , noteReplyTo   = Just $ fromMaybe uTicket muParent
+                , noteContext   = Just uTicket
+                , notePublished = Nothing
+                , noteSource    = msg'
+                , noteContent   = contentHtml
+                }
+        ExceptT $ createNoteC hLocal note
+    openTicket ((h, shr, prj), TextHtml title, TextPandocMarkdown desc) = do
+        encodeRouteLocal <- getEncodeRouteLocal
+        encodeRouteFed <- getEncodeRouteFed
+        local <- hostIsLocal h
+        descHtml <- ExceptT . pure $ renderPandocMarkdown desc
+        summary <-
+            TextHtml . TL.toStrict . renderHtml <$>
+                withUrlRenderer
+                    [hamlet|
+                        <p>
+                          <a href=@{SharerR shrAuthor}>
+                            #{shr2text shrAuthor}
+                          \ offered a ticket to project #
+                          $if local
+                            <a href=@{ProjectR shr prj}>
+                              ./s/#{shr2text shr}/p/#{prj2text prj}
+                          $else
+                            <a href=#{renderObjURI $ encodeRouteFed h $ ProjectR shr prj}>
+                              #{renderAuthority h}/s/#{shr2text shr}/p/#{prj2text prj}
+                          : #{preEscapedToHtml title}.
+                    |]
+        let recipsA = [ProjectR shr prj]
+            recipsC = [ProjectTeamR shr prj, ProjectFollowersR shr prj]
+            ticketAP = AP.Ticket
+                { ticketLocal        = Nothing
+                , ticketAttributedTo = encodeRouteLocal $ SharerR shrAuthor
+                , ticketPublished    = Nothing
+                , ticketUpdated      = Nothing
+                , ticketName         = Nothing
+                , ticketSummary      = TextHtml title
+                , ticketContent      = TextHtml descHtml
+                , ticketSource       = TextPandocMarkdown desc
+                , ticketAssignedTo   = Nothing
+                , ticketIsResolved   = False
+                }
+            offer = Offer
+                { offerObject = ticketAP
+                , offerTarget = encodeRouteFed h $ ProjectR shr prj
+                }
+            audience = Audience
+                { audienceTo        =
+                    map (encodeRouteFed h) $ recipsA ++ recipsC
+                , audienceBto       = []
+                , audienceCc        = []
+                , audienceBcc       = []
+                , audienceGeneral   = []
+                , audienceNonActors = map (encodeRouteFed h) recipsC
+                }
+        ExceptT $ offerTicketC shrAuthor summary audience offer
+    follow (uObject@(ObjURI hObject luObject), uRecip) = do
+        (summary, audience, followAP) <-
+            C.follow shrAuthor uObject uRecip False
+        ExceptT $ followC shrAuthor summary audience followAP
+
+setFollowMessage :: ShrIdent -> Either Text OutboxItemId -> Handler ()
+setFollowMessage _   (Left err)    = setMessage $ toHtml err
+setFollowMessage shr (Right obiid) = do
+    obikhid <- encodeKeyHashid obiid
+    setMessage =<<
+        withUrlRenderer
+            [hamlet|
+                <a href=@{SharerOutboxItemR shr obikhid}>
+                  Follow request published!
+            |]
+
+postSharerFollowR :: ShrIdent -> Handler ()
+postSharerFollowR shrObject = do
+    shrAuthor <- getUserShrIdent
+    (summary, audience, follow) <- followSharer shrAuthor shrObject False
+    eid <- followC shrAuthor summary audience follow
+    setFollowMessage shrAuthor eid
+    redirect $ SharerR shrObject
+
+postProjectFollowR :: ShrIdent -> PrjIdent -> Handler ()
+postProjectFollowR shrObject prjObject = do
+    shrAuthor <- getUserShrIdent
+    (summary, audience, follow) <- followProject shrAuthor shrObject prjObject False
+    eid <- followC shrAuthor summary audience follow
+    setFollowMessage shrAuthor eid
+    redirect $ ProjectR shrObject prjObject
+
+postTicketFollowR :: ShrIdent -> PrjIdent -> Int -> Handler ()
+postTicketFollowR shrObject prjObject numObject = do
+    shrAuthor <- getUserShrIdent
+    (summary, audience, follow) <- followTicket shrAuthor shrObject prjObject numObject False
+    eid <- followC shrAuthor summary audience follow
+    setFollowMessage shrAuthor eid
+    redirect $ TicketR shrObject prjObject numObject
+
+postRepoFollowR :: ShrIdent -> RpIdent -> Handler ()
+postRepoFollowR shrObject rpObject = do
+    shrAuthor <- getUserShrIdent
+    (summary, audience, follow) <- followRepo shrAuthor shrObject rpObject False
+    eid <- followC shrAuthor summary audience follow
+    setFollowMessage shrAuthor eid
+    redirect $ RepoR shrObject rpObject
+
+notificationForm :: Maybe (Maybe (InboxItemId, Bool)) -> Form (Maybe (InboxItemId, Bool))
+notificationForm defs = renderDivs $ mk
+    <$> aopt hiddenField (name "Inbox Item ID#") (fmap fst <$> defs)
+    <*> aopt hiddenField (name "New unread flag") (fmap snd <$> defs)
+    where
+    name t = FieldSettings "" Nothing Nothing (Just t) []
+    mk Nothing     Nothing       = Nothing
+    mk (Just ibid) (Just unread) = Just (ibid, unread)
+    mk _           _             = error "Missing hidden field?"
+
+getNotificationsR :: ShrIdent -> Handler Html
+getNotificationsR shr = do
+    items <- runDB $ do
+        sid <- getKeyBy404 $ UniqueSharer shr
+        p <- getValBy404 $ UniquePersonIdent sid
+        let ibid = personInbox p
+        map adaptItem <$> getItems ibid
+    notifications <- for items $ \ (ibiid, activity) -> do
+        ((_result, widget), enctype) <-
+            runFormPost $ notificationForm $ Just $ Just (ibiid, False)
+        return (activity, widget, enctype)
+    ((_result, widgetAll), enctypeAll) <-
+        runFormPost $ notificationForm $ Just Nothing
+    showTime <- getShowTime
+    defaultLayout $(widgetFile "person/notifications")
+    where
+    getItems ibid =
+        E.select $ E.from $
+            \ (ib `E.LeftOuterJoin` (ibl `E.InnerJoin` ob) `E.LeftOuterJoin` (ibr `E.InnerJoin` ract)) -> do
+                E.on $ ibr E.?. InboxItemRemoteActivity E.==. ract E.?. RemoteActivityId
+                E.on $ E.just (ib E.^. InboxItemId) E.==. ibr E.?. InboxItemRemoteItem
+                E.on $ ibl E.?. InboxItemLocalActivity E.==. ob E.?. OutboxItemId
+                E.on $ E.just (ib E.^. InboxItemId) E.==. ibl E.?. InboxItemLocalItem
+                E.where_
+                    $ ( E.isNothing (ibr E.?. InboxItemRemoteInbox) E.||.
+                        ibr E.?. InboxItemRemoteInbox E.==. E.just (E.val ibid)
+                      )
+                    E.&&.
+                      ( E.isNothing (ibl E.?. InboxItemLocalInbox) E.||.
+                        ibl E.?. InboxItemLocalInbox E.==. E.just (E.val ibid)
+                      )
+                    E.&&.
+                      ib E.^. InboxItemUnread E.==. E.val True
+                E.orderBy [E.desc $ ib E.^. InboxItemId]
+                return
+                    ( ib E.^. InboxItemId
+                    , ob E.?. OutboxItemActivity
+                    , ob E.?. OutboxItemPublished
+                    , ract E.?. RemoteActivityContent
+                    , ract E.?. RemoteActivityReceived
+                    )
+    adaptItem
+        (E.Value ibid, E.Value mact, E.Value mpub, E.Value mobj, E.Value mrec) =
+            case (mact, mpub, mobj, mrec) of
+                (Nothing, Nothing, Nothing, Nothing) ->
+                    error $ ibiidString ++ " neither local nor remote"
+                (Just _, Just _, Just _, Just _) ->
+                    error $ ibiidString ++ " both local and remote"
+                (Just act, Just pub, Nothing, Nothing) ->
+                    (ibid, (persistJSONObject act, (pub, False)))
+                (Nothing, Nothing, Just obj, Just rec) ->
+                    (ibid, (persistJSONObject obj, (rec, True)))
+                _ -> error $ "Unexpected query result for " ++ ibiidString
+        where
+        ibiidString = "InboxItem #" ++ show (E.fromSqlKey ibid)
+
+postNotificationsR :: ShrIdent -> Handler Html
+postNotificationsR shr = do
+    ((result, _widget), _enctype) <- runFormPost $ notificationForm Nothing
+    case result of
+        FormSuccess mitem -> do
+            (multi, markedUnread) <- runDB $ do
+                sid <- getKeyBy404 $ UniqueSharer shr
+                p <- getValBy404 $ UniquePersonIdent sid
+                let ibid = personInbox p
+                case mitem of
+                    Nothing -> do
+                        ibiids <- map E.unValue <$> getItems ibid
+                        updateWhere
+                            [InboxItemId <-. ibiids]
+                            [InboxItemUnread =. False]
+                        return (True, False)
+                    Just (ibiid, unread) -> do
+                        mibl <- getValBy $ UniqueInboxItemLocalItem ibiid
+                        mibr <- getValBy $ UniqueInboxItemRemoteItem ibiid
+                        mib <-
+                            requireEitherM
+                                mibl
+                                mibr
+                                "Unused InboxItem"
+                                "InboxItem used more than once"
+                        let samePid =
+                                case mib of
+                                    Left ibl ->
+                                        inboxItemLocalInbox ibl == ibid
+                                    Right ibr ->
+                                        inboxItemRemoteInbox ibr == ibid
+                        if samePid
+                            then do
+                                update ibiid [InboxItemUnread =. unread]
+                                return (False, unread)
+                            else
+                                permissionDenied
+                                    "Notification belongs to different user"
+            setMessage $
+                if multi
+                    then "Items marked as read."
+                    else if markedUnread
+                        then "Item marked as unread."
+                        else "Item marked as read."
+        FormMissing -> do
+            setMessage "Field(s) missing"
+        FormFailure l -> do
+            setMessage $ toHtml $ "Marking as read failed:" <> T.pack (show l)
+    redirect $ NotificationsR shr
+    where
+    getItems ibid =
+        E.select $ E.from $
+            \ (ib `E.LeftOuterJoin` ibl `E.LeftOuterJoin` ibr) -> do
+                E.on $ E.just (ib E.^. InboxItemId) E.==. ibr E.?. InboxItemRemoteItem
+                E.on $ E.just (ib E.^. InboxItemId) E.==. ibl E.?. InboxItemLocalItem
+                E.where_
+                    $ ( E.isNothing (ibr E.?. InboxItemRemoteInbox) E.||.
+                        ibr E.?. InboxItemRemoteInbox E.==. E.just (E.val ibid)
+                      )
+                    E.&&.
+                      ( E.isNothing (ibl E.?. InboxItemLocalInbox) E.||.
+                        ibl E.?. InboxItemLocalInbox E.==. E.just (E.val ibid)
+                      )
+                    E.&&.
+                      ib E.^. InboxItemUnread E.==. E.val True
+                return $ ib E.^. InboxItemId
+    -- TODO copied from Vervis.Federation, put this in 1 place
+    requireEitherM
+        :: MonadIO m => Maybe a -> Maybe b -> String -> String -> m (Either a b)
+    requireEitherM mx my f t =
+        case requireEither mx my of
+            Left b    -> liftIO $ throwIO $ userError $ if b then t else f
+            Right exy -> return exy

src/Vervis/Handler/Inbox.hs

@@ -21,18 +21,14 @@ module Vervis.Handler.Inbox
     , postSharerInboxR
     , postProjectInboxR
     , postRepoInboxR
-    , getPublishR
     , getSharerOutboxR
     , getSharerOutboxItemR
-    , postSharerOutboxR
     , getProjectOutboxR
     , getProjectOutboxItemR
     , getRepoOutboxR
     , getRepoOutboxItemR
     , getActorKey1R
     , getActorKey2R
-    , getNotificationsR
-    , postNotificationsR
     )
 where
 
@@ -105,6 +101,8 @@ import Vervis.Model.Ident
 import Vervis.Paginate
 import Vervis.Settings
 
+import qualified Vervis.Client as C
+
 getShowTime = showTime <$> liftIO getCurrentTime
     where
     showTime now =
@@ -334,127 +332,6 @@ jsonField = checkMMap fromTextarea toTextarea textareaField
     fromTextarea = return . first T.pack . eitherDecodeStrict' . encodeUtf8 . unTextarea
 -}
 
-fedUriField
-    :: (Monad m, RenderMessage (HandlerSite m) FormMessage) => Field m FedURI
-fedUriField = Field
-    { fieldParse = parseHelper $ \ t ->
-        case parseObjURI t of
-            Left e  -> Left $ MsgInvalidUrl $ T.pack e <> ": " <> t
-            Right u -> Right u
-    , fieldView = \theId name attrs val isReq ->
-        [whamlet|<input ##{theId} name=#{name} *{attrs} type=url :isReq:required value=#{either id renderObjURI val}>|]
-    , fieldEnctype = UrlEncoded
-    }
-
-ticketField
-    :: (Route App -> LocalURI) -> Field Handler (Host, ShrIdent, PrjIdent, Int)
-ticketField encodeRouteLocal = checkMMap toTicket fromTicket fedUriField
-    where
-    toTicket uTicket = runExceptT $ do
-        let ObjURI hTicket luTicket = uTicket
-        route <-
-            case decodeRouteLocal luTicket of
-                Nothing -> throwE ("Not a valid route" :: Text)
-                Just r -> return r
-        case route of
-            TicketR shr prj num -> return (hTicket, shr, prj, num)
-            _ -> throwE "Not a ticket route"
-    fromTicket (h, shr, prj, num) =
-        ObjURI h $ encodeRouteLocal $ TicketR shr prj num
-
-projectField
-    :: (Route App -> LocalURI) -> Field Handler (Host, ShrIdent, PrjIdent)
-projectField encodeRouteLocal = checkMMap toProject fromProject fedUriField
-    where
-    toProject u = runExceptT $ do
-        let ObjURI h lu = u
-        route <-
-            case decodeRouteLocal lu of
-                Nothing -> throwE ("Not a valid route" :: Text)
-                Just r -> return r
-        case route of
-            ProjectR shr prj -> return (h, shr, prj)
-            _ -> throwE "Not a project route"
-    fromProject (h, shr, prj) = ObjURI h $ encodeRouteLocal $ ProjectR shr prj
-
-publishCommentForm
-    :: Form ((Host, ShrIdent, PrjIdent, Int), Maybe FedURI, Text)
-publishCommentForm html = do
-    enc <- getEncodeRouteLocal
-    flip renderDivs html $ (,,)
-        <$> areq (ticketField enc) "Ticket"      (Just deft)
-        <*> aopt fedUriField       "Replying to" (Just $ Just defp)
-        <*> areq textField         "Message"     (Just defmsg)
-    where
-    deft = (Authority "forge.angeley.es" Nothing, text2shr "fr33", text2prj "sandbox", 1)
-    defp = ObjURI (Authority "forge.angeley.es" Nothing) $ LocalURI "/s/fr33/m/2f1a7"
-    defmsg = "Hi! I'm testing federation. Can you see my message? :)"
-
-openTicketForm
-    :: Form ((Host, ShrIdent, PrjIdent), TextHtml, TextPandocMarkdown)
-openTicketForm html = do
-    enc <- getEncodeRouteLocal
-    flip renderDivs html $ (,,)
-        <$> areq (projectField enc) "Project"     (Just defj)
-        <*> ( TextHtml . sanitizeBalance <$>
-              areq textField        "Title"       (Just deft)
-            )
-        <*> ( TextPandocMarkdown . T.filter (/= '\r') . unTextarea <$>
-              areq textareaField    "Description" (Just defd)
-            )
-    where
-    defj = (Authority "forge.angeley.es" Nothing, text2shr "fr33", text2prj "sandbox")
-    deft = "Time slows down when tasting coconut ice-cream"
-    defd = "Is that slow-motion effect intentional? :)"
-
-followForm :: Form (FedURI, FedURI)
-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}>
-          ^{widget1}
-          <input type=submit>
-
-        <h1>Open a new ticket
-        <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
-getUserShrIdent = do
-    Entity _ p <- requireVerifiedAuth
-    s <- runDB $ get404 $ personIdent p
-    return $ sharerIdent s
-
-getPublishR :: Handler Html
-getPublishR = do
-    shr <- getUserShrIdent
-    ((_result1, widget1), enctype1) <-
-        runFormPost $ identifyForm "f1" publishCommentForm
-    ((_result2, widget2), enctype2) <-
-        runFormPost $ identifyForm "f2" openTicketForm
-    ((_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
@@ -538,150 +415,6 @@ getSharerOutboxItemR shr obikhid = getOutboxItem here getObid obikhid
         p <- getValBy404 $ UniquePersonIdent sid
         return $ personOutbox p
 
-postSharerOutboxR :: ShrIdent -> Handler Html
-postSharerOutboxR shrAuthor = do
-    federation <- getsYesod $ appFederation . appSettings
-    unless federation badMethod
-
-    ((result1, widget1), enctype1) <-
-        runFormPost $ identifyForm "f1" publishCommentForm
-    ((result2, widget2), enctype2) <-
-        runFormPost $ identifyForm "f2" openTicketForm
-    ((result3, widget3), enctype3) <-
-        runFormPost $ identifyForm "f3" followForm
-    let result
-            =   Left <$> result1
-            <|> Right . Left <$> result2
-            <|> Right . Right <$> result3
-
-    eid <- runExceptT $ do
-        input <-
-            case result of
-                FormMissing -> throwE "Field(s) missing"
-                FormFailure _l -> throwE "Invalid input, see below"
-                FormSuccess r -> return r
-        bitraverse publishComment (bitraverse openTicket follow) input
-    case eid of
-        Left err -> setMessage $ toHtml err
-        Right id_ ->
-            case id_ of
-                Left lmid -> do
-                    lmkhid <- encodeKeyHashid lmid
-                    renderUrl <- getUrlRender
-                    let u = renderUrl $ MessageR shrAuthor lmkhid
-                    setMessage $ toHtml $ "Message created! ID: " <> u
-                Right (Left _obiid) ->
-                    setMessage "Ticket offer published!"
-                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
-        encodeRouteLocal <- getEncodeRouteLocal
-        let msg' = T.filter (/= '\r') msg
-        contentHtml <- ExceptT . pure $ renderPandocMarkdown msg'
-        let encodeRecipRoute = ObjURI hTicket . encodeRouteLocal
-            uTicket = encodeRecipRoute $ TicketR shrTicket prj num
-            ObjURI hLocal luAuthor = encodeRouteFed $ SharerR shrAuthor
-            collections =
-                [ ProjectFollowersR shrTicket prj
-                , TicketParticipantsR shrTicket prj num
-                , TicketTeamR shrTicket prj num
-                ]
-            recips = ProjectR shrTicket prj : collections
-            note = Note
-                { noteId        = Nothing
-                , noteAttrib    = luAuthor
-                , noteAudience  = Audience
-                    { audienceTo        = map encodeRecipRoute recips
-                    , audienceBto       = []
-                    , audienceCc        = []
-                    , audienceBcc       = []
-                    , audienceGeneral   = []
-                    , audienceNonActors = map encodeRecipRoute collections
-                    }
-                , noteReplyTo   = Just $ fromMaybe uTicket muParent
-                , noteContext   = Just uTicket
-                , notePublished = Nothing
-                , noteSource    = msg'
-                , noteContent   = contentHtml
-                }
-        ExceptT $ createNoteC hLocal note
-    openTicket ((h, shr, prj), TextHtml title, TextPandocMarkdown desc) = do
-        encodeRouteLocal <- getEncodeRouteLocal
-        encodeRouteFed <- getEncodeRouteFed
-        local <- hostIsLocal h
-        descHtml <- ExceptT . pure $ renderPandocMarkdown desc
-        summary <-
-            TextHtml . TL.toStrict . renderHtml <$>
-                withUrlRenderer
-                    [hamlet|
-                        <p>
-                          <a href=@{SharerR shrAuthor}>
-                            #{shr2text shrAuthor}
-                          \ offered a ticket to project #
-                          $if local
-                            <a href=@{ProjectR shr prj}>
-                              ./s/#{shr2text shr}/p/#{prj2text prj}
-                          $else
-                            <a href=#{renderObjURI $ encodeRouteFed h $ ProjectR shr prj}>
-                              #{renderAuthority h}/s/#{shr2text shr}/p/#{prj2text prj}
-                          : #{preEscapedToHtml title}.
-                    |]
-        let recipsA = [ProjectR shr prj]
-            recipsC = [ProjectTeamR shr prj, ProjectFollowersR shr prj]
-            ticket = Ticket
-                { ticketLocal        = Nothing
-                , ticketAttributedTo = encodeRouteLocal $ SharerR shrAuthor
-                , ticketPublished    = Nothing
-                , ticketUpdated      = Nothing
-                , ticketName         = Nothing
-                , ticketSummary      = TextHtml title
-                , ticketContent      = TextHtml descHtml
-                , ticketSource       = TextPandocMarkdown desc
-                , ticketAssignedTo   = Nothing
-                , ticketIsResolved   = False
-                }
-            offer = Offer
-                { offerObject = ticket
-                , offerTarget = encodeRouteFed h $ ProjectR shr prj
-                }
-            audience = Audience
-                { audienceTo        =
-                    map (encodeRouteFed h) $ recipsA ++ recipsC
-                , audienceBto       = []
-                , audienceCc        = []
-                , audienceBcc       = []
-                , audienceGeneral   = []
-                , 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
     where
@@ -739,143 +472,3 @@ getActorKey1R = getActorKey (\ (k1, _, _) -> k1) ActorKey1R
 
 getActorKey2R :: Handler TypedContent
 getActorKey2R = getActorKey (\ (_, k2, _) -> k2) ActorKey2R
-
-notificationForm :: Maybe (Maybe (InboxItemId, Bool)) -> Form (Maybe (InboxItemId, Bool))
-notificationForm defs = renderDivs $ mk
-    <$> aopt hiddenField (name "Inbox Item ID#") (fmap fst <$> defs)
-    <*> aopt hiddenField (name "New unread flag") (fmap snd <$> defs)
-    where
-    name t = FieldSettings "" Nothing Nothing (Just t) []
-    mk Nothing     Nothing       = Nothing
-    mk (Just ibid) (Just unread) = Just (ibid, unread)
-    mk _           _             = error "Missing hidden field?"
-
-getNotificationsR :: ShrIdent -> Handler Html
-getNotificationsR shr = do
-    items <- runDB $ do
-        sid <- getKeyBy404 $ UniqueSharer shr
-        p <- getValBy404 $ UniquePersonIdent sid
-        let ibid = personInbox p
-        map adaptItem <$> getItems ibid
-    notifications <- for items $ \ (ibiid, activity) -> do
-        ((_result, widget), enctype) <-
-            runFormPost $ notificationForm $ Just $ Just (ibiid, False)
-        return (activity, widget, enctype)
-    ((_result, widgetAll), enctypeAll) <-
-        runFormPost $ notificationForm $ Just Nothing
-    showTime <- getShowTime
-    defaultLayout $(widgetFile "person/notifications")
-    where
-    getItems ibid =
-        E.select $ E.from $
-            \ (ib `E.LeftOuterJoin` (ibl `E.InnerJoin` ob) `E.LeftOuterJoin` (ibr `E.InnerJoin` ract)) -> do
-                E.on $ ibr E.?. InboxItemRemoteActivity E.==. ract E.?. RemoteActivityId
-                E.on $ E.just (ib E.^. InboxItemId) E.==. ibr E.?. InboxItemRemoteItem
-                E.on $ ibl E.?. InboxItemLocalActivity E.==. ob E.?. OutboxItemId
-                E.on $ E.just (ib E.^. InboxItemId) E.==. ibl E.?. InboxItemLocalItem
-                E.where_
-                    $ ( E.isNothing (ibr E.?. InboxItemRemoteInbox) E.||.
-                        ibr E.?. InboxItemRemoteInbox E.==. E.just (E.val ibid)
-                      )
-                    E.&&.
-                      ( E.isNothing (ibl E.?. InboxItemLocalInbox) E.||.
-                        ibl E.?. InboxItemLocalInbox E.==. E.just (E.val ibid)
-                      )
-                    E.&&.
-                      ib E.^. InboxItemUnread E.==. E.val True
-                E.orderBy [E.desc $ ib E.^. InboxItemId]
-                return
-                    ( ib E.^. InboxItemId
-                    , ob E.?. OutboxItemActivity
-                    , ob E.?. OutboxItemPublished
-                    , ract E.?. RemoteActivityContent
-                    , ract E.?. RemoteActivityReceived
-                    )
-    adaptItem
-        (E.Value ibid, E.Value mact, E.Value mpub, E.Value mobj, E.Value mrec) =
-            case (mact, mpub, mobj, mrec) of
-                (Nothing, Nothing, Nothing, Nothing) ->
-                    error $ ibiidString ++ " neither local nor remote"
-                (Just _, Just _, Just _, Just _) ->
-                    error $ ibiidString ++ " both local and remote"
-                (Just act, Just pub, Nothing, Nothing) ->
-                    (ibid, (persistJSONObject act, (pub, False)))
-                (Nothing, Nothing, Just obj, Just rec) ->
-                    (ibid, (persistJSONObject obj, (rec, True)))
-                _ -> error $ "Unexpected query result for " ++ ibiidString
-        where
-        ibiidString = "InboxItem #" ++ show (fromSqlKey ibid)
-
-postNotificationsR :: ShrIdent -> Handler Html
-postNotificationsR shr = do
-    ((result, _widget), _enctype) <- runFormPost $ notificationForm Nothing
-    case result of
-        FormSuccess mitem -> do
-            (multi, markedUnread) <- runDB $ do
-                sid <- getKeyBy404 $ UniqueSharer shr
-                p <- getValBy404 $ UniquePersonIdent sid
-                let ibid = personInbox p
-                case mitem of
-                    Nothing -> do
-                        ibiids <- map E.unValue <$> getItems ibid
-                        updateWhere
-                            [InboxItemId <-. ibiids]
-                            [InboxItemUnread =. False]
-                        return (True, False)
-                    Just (ibiid, unread) -> do
-                        mibl <- getValBy $ UniqueInboxItemLocalItem ibiid
-                        mibr <- getValBy $ UniqueInboxItemRemoteItem ibiid
-                        mib <-
-                            requireEitherM
-                                mibl
-                                mibr
-                                "Unused InboxItem"
-                                "InboxItem used more than once"
-                        let samePid =
-                                case mib of
-                                    Left ibl ->
-                                        inboxItemLocalInbox ibl == ibid
-                                    Right ibr ->
-                                        inboxItemRemoteInbox ibr == ibid
-                        if samePid
-                            then do
-                                update ibiid [InboxItemUnread =. unread]
-                                return (False, unread)
-                            else
-                                permissionDenied
-                                    "Notification belongs to different user"
-            setMessage $
-                if multi
-                    then "Items marked as read."
-                    else if markedUnread
-                        then "Item marked as unread."
-                        else "Item marked as read."
-        FormMissing -> do
-            setMessage "Field(s) missing"
-        FormFailure l -> do
-            setMessage $ toHtml $ "Marking as read failed:" <> T.pack (show l)
-    redirect $ NotificationsR shr
-    where
-    getItems ibid =
-        E.select $ E.from $
-            \ (ib `E.LeftOuterJoin` ibl `E.LeftOuterJoin` ibr) -> do
-                E.on $ E.just (ib E.^. InboxItemId) E.==. ibr E.?. InboxItemRemoteItem
-                E.on $ E.just (ib E.^. InboxItemId) E.==. ibl E.?. InboxItemLocalItem
-                E.where_
-                    $ ( E.isNothing (ibr E.?. InboxItemRemoteInbox) E.||.
-                        ibr E.?. InboxItemRemoteInbox E.==. E.just (E.val ibid)
-                      )
-                    E.&&.
-                      ( E.isNothing (ibl E.?. InboxItemLocalInbox) E.||.
-                        ibl E.?. InboxItemLocalInbox E.==. E.just (E.val ibid)
-                      )
-                    E.&&.
-                      ib E.^. InboxItemUnread E.==. E.val True
-                return $ ib E.^. InboxItemId
-    -- TODO copied from Vervis.Federation, put this in 1 place
-    requireEitherM
-        :: MonadIO m => Maybe a -> Maybe b -> String -> String -> m (Either a b)
-    requireEitherM mx my f t =
-        case requireEither mx my of
-            Left b    -> liftIO $ throwIO $ userError $ if b then t else f
-            Right exy -> return exy

src/Vervis/Migration.hs

@@ -1069,6 +1069,24 @@ changes hLocal ctx =
         "Outbox"
       -- 139
     , addUnique "Repo" $ Unique "UniqueRepoOutbox" ["outbox"]
+      -- 140
+    , addFieldRefRequiredEmpty "Follow" "follow" "OutboxItem"
+      -- 141
+    , addUnique "Follow" $ Unique "UniqueFollowFollow" ["follow"]
+      -- 142
+    , addFieldRefRequiredEmpty "RemoteFollow" "follow" "RemoteActivity"
+      -- 143
+    , addUnique "RemoteFollow" $ Unique "UniqueRemoteFollowFollow" ["follow"]
+      -- 144
+    , addEntities model_2019_09_25
+      -- 145
+    , addFieldRefRequiredEmpty "Follow" "accept" "OutboxItem"
+      -- 146
+    , addUnique "Follow" $ Unique "UniqueFollowAccept" ["accept"]
+      -- 147
+    , addFieldRefRequiredEmpty "RemoteFollow" "accept" "OutboxItem"
+      -- 148
+    , addUnique "RemoteFollow" $ Unique "UniqueRemoteFollowAccept" ["accept"]
     ]
 
 migrateDB

src/Vervis/Migration/Model.hs

@@ -124,6 +124,7 @@ module Vervis.Migration.Model
     , Person130
     , Outbox138Generic (..)
     , Repo138
+    , model_2019_09_25
     )
 where
 
@@ -251,3 +252,6 @@ makeEntitiesMigration "130"
 
 makeEntitiesMigration "138"
     $(modelFile "migrations/2019_09_10.model")
+
+model_2019_09_25 :: [Entity SqlBackend]
+model_2019_09_25 = $(schema "2019_09_25")

src/Web/ActivityPub.hs

@@ -58,6 +58,7 @@ module Web.ActivityPub
     , Offer (..)
     , Push (..)
     , Reject (..)
+    , Undo (..)
     , Audience (..)
     , SpecificActivity (..)
     , Activity (..)
@@ -1005,6 +1006,7 @@ encodeCreate authority actor (Create obj) =
 
 data Follow u = Follow
     { followObject  :: ObjURI u
+    , followContext :: Maybe (ObjURI u)
     , followHide    :: Bool
     }
 
@@ -1012,11 +1014,13 @@ parseFollow :: UriMode u => Object -> Parser (Follow u)
 parseFollow o =
     Follow
         <$> o .:  "object"
+        <*> o .:? "context"
         <*> o .:  "hide"
 
 encodeFollow :: UriMode u => Follow u -> Series
-encodeFollow (Follow obj hide)
+encodeFollow (Follow obj mcontext hide)
     =  "object"  .=  obj
+    <> "context" .=? mcontext
     <> "hide"    .=  hide
 
 data Offer u = Offer
@@ -1086,6 +1090,16 @@ parseReject o = Reject <$> o .: "object"
 encodeReject :: UriMode u => Reject u -> Series
 encodeReject (Reject obj) = "object" .= obj
 
+data Undo u = Undo
+    { undoObject :: LocalURI
+    }
+
+parseUndo :: UriMode u => Authority u -> Object -> Parser (Undo u)
+parseUndo a o = Undo <$> withAuthorityO a (o .: "object")
+
+encodeUndo :: UriMode u => Authority u -> Undo u -> Series
+encodeUndo a (Undo obj) = "object" .= ObjURI a obj
+
 data SpecificActivity u
     = AcceptActivity (Accept u)
     | CreateActivity (Create u)
@@ -1093,6 +1107,7 @@ data SpecificActivity u
     | OfferActivity  (Offer u)
     | PushActivity   (Push u)
     | RejectActivity (Reject u)
+    | UndoActivity   (Undo u)
 
 data Activity u = Activity
     { activityId       :: Maybe LocalURI
@@ -1121,6 +1136,7 @@ instance ActivityPub Activity where
                         "Offer"  -> OfferActivity  <$> parseOffer o a actor
                         "Push"   -> PushActivity   <$> parsePush a o
                         "Reject" -> RejectActivity <$> parseReject o
+                        "Undo"   -> UndoActivity   <$> parseUndo a o
                         _ ->
                             fail $
                                 "Unrecognized activity type: " ++ T.unpack typ
@@ -1145,6 +1161,7 @@ instance ActivityPub Activity where
         encodeSpecific h u (OfferActivity a)  = encodeOffer h u a
         encodeSpecific h _ (PushActivity a)   = encodePush h a
         encodeSpecific _ _ (RejectActivity a) = encodeReject a
+        encodeSpecific h _ (UndoActivity a)   = encodeUndo h a
 
 typeActivityStreams2 :: ContentType
 typeActivityStreams2 = "application/activity+json"

src/Yesod/MonadSite.hs

@@ -38,6 +38,7 @@ import Control.Monad.IO.Unlift
 import Control.Monad.Logger.CallStack
 import Control.Monad.Trans.Class
 import Control.Monad.Trans.Except
+import Control.Monad.Trans.Maybe
 import Control.Monad.Trans.Reader
 import Data.Functor
 import Data.Text (Text)
@@ -77,6 +78,11 @@ instance MonadSite m => MonadSite (ReaderT r m) where
     askSite                    = lift askSite
     askUrlRenderParams         = lift askUrlRenderParams
 
+instance MonadSite m => MonadSite (MaybeT m) where
+    type SiteEnv (MaybeT m) = SiteEnv m
+    askSite                 = lift askSite
+    askUrlRenderParams      = lift askUrlRenderParams
+
 instance MonadSite m => MonadSite (ExceptT e m) where
     type SiteEnv (ExceptT e m) = SiteEnv m
     askSite                    = lift askSite

vervis.cabal

@@ -123,6 +123,7 @@ library
                        Vervis.BinaryBody
                        Vervis.Changes
                        Vervis.ChangeFeed
+                       Vervis.Client
                        Vervis.Colour
                        Vervis.Content
                        Vervis.Darcs
@@ -153,6 +154,7 @@ library
                        Vervis.Foundation
                        Vervis.Git
                        Vervis.GraphProxy
+                       Vervis.Handler.Client
                        Vervis.Handler.Common
                        Vervis.Handler.Discussion
                        Vervis.Handler.Git