S2S: Support following sharer-patch and repo-patch

Also fixed a bug in which trying to follow a ticket with nonexistent
ltkhid/talkhid would result with 404 as if the actor inbox is nonexistent. Now,
there's a friendly message reported.

src/Vervis/Federation/Offer.hs

@@ -80,6 +80,8 @@ import Vervis.Foundation
 import Vervis.Model
 import Vervis.Model.Ident
 import Vervis.Model.Ticket
+import Vervis.Patch
+import Vervis.Ticket
 
 sharerAcceptF
     :: ShrIdent
@@ -240,7 +242,7 @@ sharerRejectF shr now author body (Reject (ObjURI hOffer luOffer)) = do
 followF
     :: (Route App -> Maybe a)
     -> Route App
-    -> (a -> AppDB b)
+    -> (a -> AppDB (Maybe b))
     -> (b -> InboxId)
     -> (b -> OutboxId)
     -> (b -> FollowerSetId)
@@ -267,30 +269,33 @@ followF
                         (activityId $ actbActivity body)
                         "Follow without 'id'"
                 emsg <- lift $ runDB $ do
-                    recip <- getRecip obj
+                    mrecip <- getRecip obj
-                    newItem <- insertToInbox luFollow $ recipInbox recip
+                    case mrecip of
-                    case newItem of
+                        Nothing -> return $ Left "Follow object not found, ignoring activity"
-                        Nothing -> return $ Left "Activity already exists in inbox, not using"
+                        Just recip -> do
-                        Just ractid -> do
+                            newItem <- insertToInbox luFollow $ recipInbox recip
-                            let raidAuthor = remoteAuthorId author
+                            case newItem of
-                            ra <- getJust raidAuthor
+                                Nothing -> return $ Left "Activity already exists in inbox, not using"
-                            ro <- getJust $ remoteActorIdent ra
+                                Just ractid -> do
-                            (obiid, doc) <-
+                                    let raidAuthor = remoteAuthorId author
-                                insertAcceptToOutbox
+                                    ra <- getJust raidAuthor
-                                    ra
+                                    ro <- getJust $ remoteActorIdent ra
-                                    luFollow
+                                    (obiid, doc) <-
-                                    (recipOutbox recip)
+                                        insertAcceptToOutbox
-                            newFollow <- insertFollow ractid obiid $ recipFollowers recip
+                                            ra
-                            if newFollow
+                                            luFollow
-                                then Right <$> do
+                                            (recipOutbox recip)
-                                    let raInfo = RemoteRecipient raidAuthor (remoteObjectIdent ro) (remoteActorInbox ra) (remoteActorErrorSince ra)
+                                    newFollow <- insertFollow ractid obiid $ recipFollowers recip
-                                        iidAuthor = remoteAuthorInstance author
+                                    if newFollow
-                                        hAuthor = objUriAuthority $ remoteAuthorURI author
+                                        then Right <$> do
-                                        hostSection = ((iidAuthor, hAuthor), raInfo :| [])
+                                            let raInfo = RemoteRecipient raidAuthor (remoteObjectIdent ro) (remoteActorInbox ra) (remoteActorErrorSince ra)
-                                    (obiid, doc,) <$> deliverRemoteDB' dont obiid [] [hostSection]
+                                                iidAuthor = remoteAuthorInstance author
-                                else do
+                                                hAuthor = objUriAuthority $ remoteAuthorURI author
-                                    delete obiid
+                                                hostSection = ((iidAuthor, hAuthor), raInfo :| [])
-                                    return $ Left "You're already a follower of me"
+                                            (obiid, doc,) <$> deliverRemoteDB' dont obiid [] [hostSection]
+                                        else do
+                                            delete obiid
+                                            return $ Left "You're already a follower of me"
                 case emsg of
                     Left msg -> return msg
                     Right (obiid, doc, remotesHttp) -> do
@@ -382,23 +387,31 @@ sharerFollowF shr =
     objRoute (SharerR shr')
         | shr == shr' = Just Nothing
     objRoute (SharerTicketR shr' talkhid)
-        | shr == shr' = Just $ Just talkhid
+        | shr == shr' = Just $ Just (talkhid, False)
+    objRoute (SharerPatchR shr' talkhid)
+        | shr == shr' = Just $ Just (talkhid, True)
     objRoute _ = Nothing
 
     getRecip mtalkhid = do
         sid <- getKeyBy404 $ UniqueSharer shr
-        Entity pid p <- getBy404 $ UniquePersonIdent sid
+        p <- getValBy404 $ UniquePersonIdent sid
-        mt <- for mtalkhid $ \ talkhid -> do
+        mmt <- for mtalkhid $ \ (talkhid, patch) -> runMaybeT $ do
-            talid <- decodeKeyHashid404 talkhid
+            talid <- decodeKeyHashidM talkhid
-            tal <- get404 talid
+            if patch
-            unless (ticketAuthorLocalAuthor tal == pid) notFound
+                then do
-            mtup <- getBy $ UniqueTicketUnderProjectAuthor talid
+                    (_, Entity _ lt, _, _, _) <- MaybeT $ getSharerPatch shr talid
-            unless (isNothing mtup) notFound
+                    return lt
-            getJust $ ticketAuthorLocalTicket tal
+                else do
-        return (p, mt)
+                    (_, Entity _ lt, _, _) <- MaybeT $ getSharerTicket shr talid
+                    return lt
+        return $
+            case mmt of
+                Nothing -> Just (p, Nothing)
+                Just Nothing -> Nothing
+                Just (Just t) -> Just (p, Just t)
 
-    followers (p, Nothing)  = personFollowers p
+    followers (p, Nothing) = personFollowers p
-    followers (_, Just lt)  = localTicketFollowers lt
+    followers (_, Just lt) = localTicketFollowers lt
 
 projectFollowF
     :: ShrIdent
@@ -426,17 +439,16 @@ projectFollowF shr prj =
 
     getRecip mltkhid = do
         sid <- getKeyBy404 $ UniqueSharer shr
-        Entity jid j <- getBy404 $ UniqueProject prj sid
+        j <- getValBy404 $ UniqueProject prj sid
-        mt <- for mltkhid $ \ ltkhid -> do
+        mmt <- for mltkhid $ \ ltkhid -> runMaybeT $ do
-            ltid <- decodeKeyHashid404 ltkhid
+            ltid <- decodeKeyHashidM ltkhid
-            lt <- get404 ltid
+            (_, _, _, Entity _ lt, _, _, _) <- MaybeT $ getProjectTicket shr prj ltid
-            tclid <-
-                getKeyBy404 $ UniqueTicketContextLocal $ localTicketTicket lt
-            tpl <-
-                getValBy404 $ UniqueTicketProjectLocal tclid
-            unless (ticketProjectLocalProject tpl == jid) notFound
             return lt
-        return (j, mt)
+        return $
+            case mmt of
+                Nothing -> Just (j, Nothing)
+                Just Nothing -> Nothing
+                Just (Just t) -> Just (j, Just t)
 
     followers (j, Nothing)  = projectFollowers j
     followers (_, Just lt)  = localTicketFollowers lt
@@ -454,17 +466,32 @@ repoFollowF shr rp =
         objRoute
         (RepoR shr rp)
         getRecip
-        repoInbox
+        (repoInbox . fst)
-        repoOutbox
+        (repoOutbox . fst)
-        repoFollowers
+        followers
         (RepoOutboxItemR shr rp)
     where
-    objRoute (RepoR shr' rp') | shr == shr' && rp == rp' = Just ()
+    objRoute (RepoR shr' rp')
-    objRoute _                                           = Nothing
+        | shr == shr' && rp == rp' = Just Nothing
+    objRoute (RepoPatchR shr' rp' ltkhid)
+        | shr == shr' && rp == rp' = Just $ Just ltkhid
+    objRoute _ = Nothing
 
-    getRecip () = do
+    getRecip mltkhid = do
         sid <- getKeyBy404 $ UniqueSharer shr
-        getValBy404 $ UniqueRepo rp sid
+        r <- getValBy404 $ UniqueRepo rp sid
+        mmt <- for mltkhid $ \ ltkhid -> runMaybeT $ do
+            ltid <- decodeKeyHashidM ltkhid
+            (_, _, _, Entity _ lt, _, _, _, _) <- MaybeT $ getRepoPatch shr rp ltid
+            return lt
+        return $
+            case mmt of
+                Nothing -> Just (r, Nothing)
+                Just Nothing -> Nothing
+                Just (Just t) -> Just (r, Just t)
+
+    followers (r, Nothing) = repoFollowers r
+    followers (_, Just lt) = localTicketFollowers lt
 
 undoF
     :: Route App