diff --git a/src/Vervis/API.hs b/src/Vervis/API.hs
index d2d3a10..8d92d8e 100644
--- a/src/Vervis/API.hs
+++ b/src/Vervis/API.hs
@@ -37,6 +37,7 @@ import Control.Monad.Trans.Reader
import Crypto.Hash
import Data.Aeson
import Data.Bifunctor
+import Data.Bitraversable
import Data.ByteString (ByteString)
import Data.Either
import Data.Foldable
@@ -111,6 +112,7 @@ import Vervis.Model.Ident
import Vervis.Model.Ticket
import Vervis.RemoteActorStore
import Vervis.Settings
+import Vervis.Patch
import Vervis.Ticket
verifyIsLoggedInUser
@@ -201,29 +203,44 @@ createNoteC (Entity pidUser personUser) sharerUser summary audience note = runEx
let actors =
case mproject of
Nothing -> []
- Just (shr, prj) -> [LocalActorProject shr prj]
+ Just (Left (shr, prj)) -> [LocalActorProject shr prj]
+ Just (Right (shr, rp)) -> [LocalActorRepo shr rp]
collections =
let project =
case mproject of
Nothing -> []
- Just (shr, prj) ->
+ Just (Left (shr, prj)) ->
[ LocalPersonCollectionProjectTeam shr prj
, LocalPersonCollectionProjectFollowers shr prj
]
+ Just (Right (shr, rp)) ->
+ [ LocalPersonCollectionRepoTeam shr rp
+ , LocalPersonCollectionRepoFollowers shr rp
+ ]
ticket =
case context of
Left nc ->
case nc of
- NoteContextSharerTicket shr talid ->
+ NoteContextSharerTicket shr talid False ->
let talkhid = hashTAL talid
in [ -- LocalPersonCollectionSharerTicketTeam shr talkhid
LocalPersonCollectionSharerTicketFollowers shr talkhid
]
+ NoteContextSharerTicket shr talid True ->
+ let talkhid = hashTAL talid
+ in [ -- LocalPersonCollectionSharerPatchTeam shr talkhid
+ LocalPersonCollectionSharerPatchFollowers shr talkhid
+ ]
NoteContextProjectTicket shr prj ltid ->
let ltkhid = hashLT ltid
in [ -- LocalPersonCollectionProjectTicketTeam shr prj ltkhid
LocalPersonCollectionProjectTicketFollowers shr prj ltkhid
]
+ NoteContextRepoPatch shr rp ltid ->
+ let ltkhid = hashLT ltid
+ in [ -- LocalPersonCollectionRepoPatchTeam shr rp ltkhid
+ LocalPersonCollectionRepoPatchFollowers shr rp ltkhid
+ ]
Right _ -> []
commenter = [LocalPersonCollectionSharerFollowers shrUser]
in project ++ ticket ++ commenter
@@ -251,15 +268,25 @@ createNoteC (Entity pidUser personUser) sharerUser summary audience note = runEx
parseTopic name route =
case route of
SharerTicketR shr talkhid ->
- NoteContextSharerTicket shr <$>
+ flip (NoteContextSharerTicket shr) False <$>
decodeKeyHashidE
talkhid
(name <> " sharer ticket invalid talkhid")
+ SharerPatchR shr talkhid ->
+ flip (NoteContextSharerTicket shr) True <$>
+ decodeKeyHashidE
+ talkhid
+ (name <> " sharer patch invalid talkhid")
ProjectTicketR shr prj ltkhid ->
NoteContextProjectTicket shr prj <$>
decodeKeyHashidE
ltkhid
(name <> " project ticket invalid ltkhid")
+ RepoPatchR shr rp ltkhid ->
+ NoteContextRepoPatch shr rp <$>
+ decodeKeyHashidE
+ ltkhid
+ (name <> " repo patch invalid ltkhid")
_ -> throwE $ name <> " isn't a discussion topic route"
parseNoteContext u@(ObjURI h lu) = do
hl <- hostIsLocal h
@@ -306,7 +333,7 @@ createNoteC (Entity pidUser personUser) sharerUser summary audience note = runEx
unless (any ((== h) . fst) remoteRecips) $
throwE
"Context is remote but no recipients of that host are listed"
- verifyContextRecip (Left (NoteContextSharerTicket shr _)) localRecips _ =
+ verifyContextRecip (Left (NoteContextSharerTicket shr _ _)) localRecips _ =
fromMaybeE
verify
"Local context ticket's hosting sharer isn't listed as a recipient"
@@ -323,6 +350,15 @@ createNoteC (Entity pidUser personUser) sharerUser summary audience note = runEx
sharerSet <- lookup shr localRecips
projectSet <- lookup prj $ localRecipProjectRelated sharerSet
guard $ localRecipProject $ localRecipProjectDirect projectSet
+ verifyContextRecip (Left (NoteContextRepoPatch shr rp _)) localRecips _ =
+ fromMaybeE
+ verify
+ "Local context patch's hosting repo isn't listed as a recipient"
+ where
+ verify = do
+ sharerSet <- lookup shr localRecips
+ repoSet <- lookup rp $ localRecipRepoRelated sharerSet
+ guard $ localRecipRepo $ localRecipRepoDirect repoSet
insertEmptyOutboxItem obid now = do
h <- asksSite siteInstanceHost
insert OutboxItem
@@ -334,23 +370,41 @@ createNoteC (Entity pidUser personUser) sharerUser summary audience note = runEx
j <- getJust $ ticketProjectLocalProject tpl
s <- getJust $ projectSharer j
return (sharerIdent s, projectIdent j)
+ getRepo trl = do
+ r <- getJust $ ticketRepoLocalRepo trl
+ s <- getJust $ repoSharer r
+ return (sharerIdent s, repoIdent r)
getTopicAndParent (Left context) mparent = do
(mproject, did) <-
case context of
- NoteContextSharerTicket shr talid -> do
+ NoteContextSharerTicket shr talid False -> do
(_, Entity _ lt, _, project) <- do
mticket <- lift $ getSharerTicket shr talid
fromMaybeE mticket "Note context no such local sharer-hosted ticket"
mproj <-
case project of
- Left (_, Entity _ tpl) -> lift $ Just <$> getProject tpl
+ Left (_, Entity _ tpl) -> lift $ Just . Left <$> getProject tpl
+ Right _ -> return Nothing
+ return (mproj, localTicketDiscuss lt)
+ NoteContextSharerTicket shr talid True -> do
+ (_, Entity _ lt, _, repo, _) <- do
+ mticket <- lift $ getSharerPatch shr talid
+ fromMaybeE mticket "Note context no such local sharer-hosted patch"
+ mproj <-
+ case repo of
+ Left (_, Entity _ trl) -> lift $ Just . Right <$> getRepo trl
Right _ -> return Nothing
return (mproj, localTicketDiscuss lt)
NoteContextProjectTicket shr prj ltid -> do
(_, _, _, Entity _ lt, _, _, _) <- do
mticket <- lift $ getProjectTicket shr prj ltid
fromMaybeE mticket "Note context no such local project-hosted ticket"
- return (Just (shr, prj), localTicketDiscuss lt)
+ return (Just $ Left (shr, prj), localTicketDiscuss lt)
+ NoteContextRepoPatch shr rp ltid -> do
+ (_, _, _, Entity _ lt, _, _, _, _) <- do
+ mticket <- lift $ getRepoPatch shr rp ltid
+ fromMaybeE mticket "Note context no such local project-hosted ticket"
+ return (Just $ Right (shr, rp), localTicketDiscuss lt)
mmidParent <- for mparent $ \ parent ->
case parent of
Left (shrParent, lmidParent) -> getLocalParentMessageId did shrParent lmidParent
@@ -377,9 +431,14 @@ createNoteC (Entity pidUser personUser) sharerUser summary audience note = runEx
rt <- MaybeT $ getValBy $ UniqueRemoteTicketDiscuss rdid
tar <- lift $ getJust $ remoteTicketTicket rt
let tclid = ticketAuthorRemoteTicket tar
- tpl <-
- MaybeT $ getValBy $ UniqueTicketProjectLocal tclid
- lift $ getProject tpl
+ txl <-
+ lift $
+ requireEitherAlt
+ (getValBy $ UniqueTicketProjectLocal tclid)
+ (getValBy $ UniqueTicketRepoLocal tclid)
+ "No specific TCL"
+ "Both TPL and TRL"
+ lift $ bitraverse getProject getRepo txl
return (mproj, rd, False)
Nothing -> do
did <- insert Discussion
diff --git a/src/Vervis/ActivityPub.hs b/src/Vervis/ActivityPub.hs
index 93f63df..625cf7b 100644
--- a/src/Vervis/ActivityPub.hs
+++ b/src/Vervis/ActivityPub.hs
@@ -130,8 +130,9 @@ import Vervis.Widget.Repo
import Vervis.Widget.Sharer
data NoteContext
- = NoteContextSharerTicket ShrIdent TicketAuthorLocalId
+ = NoteContextSharerTicket ShrIdent TicketAuthorLocalId Bool
| NoteContextProjectTicket ShrIdent PrjIdent LocalTicketId
+ | NoteContextRepoPatch ShrIdent RpIdent LocalTicketId
deriving Eq
hostIsLocal :: (MonadSite m, SiteEnv m ~ App) => Host -> m Bool
@@ -158,12 +159,18 @@ parseContext uContext = do
Just r -> return r
case route of
SharerTicketR shr talkhid ->
- NoteContextSharerTicket shr <$>
+ flip (NoteContextSharerTicket shr) False <$>
+ decodeKeyHashidE talkhid "Note context invalid talkhid"
+ SharerPatchR shr talkhid ->
+ flip (NoteContextSharerTicket shr) True <$>
decodeKeyHashidE talkhid "Note context invalid talkhid"
ProjectTicketR shr prj ltkhid ->
NoteContextProjectTicket shr prj <$>
decodeKeyHashidE ltkhid "Note context invalid ltkhid"
- _ -> throwE "Local context isn't a ticket route"
+ RepoPatchR shr rp ltkhid ->
+ NoteContextRepoPatch shr rp <$>
+ decodeKeyHashidE ltkhid "Note context invalid ltkhid"
+ _ -> throwE "Local context isn't a ticket/patch route"
else return $ Right uContext
parseParent
diff --git a/src/Vervis/Federation.hs b/src/Vervis/Federation.hs
index e988a27..3741dba 100644
--- a/src/Vervis/Federation.hs
+++ b/src/Vervis/Federation.hs
@@ -336,6 +336,11 @@ handleRepoInbox now shrRecip rpRecip auth body = do
ActivityAuthLocal local -> throwE $ errorLocalForwarded local
ActivityAuthRemote ra -> return ra
case activitySpecific $ actbActivity body of
+ CreateActivity (Create obj mtarget) ->
+ case obj of
+ CreateNote note ->
+ repoCreateNoteF now shrRecip rpRecip remoteAuthor body note
+ _ -> error "Unsupported create object type for repos"
FollowActivity follow ->
repoFollowF shrRecip rpRecip now remoteAuthor body follow
UndoActivity undo->
diff --git a/src/Vervis/Federation/Discussion.hs b/src/Vervis/Federation/Discussion.hs
index 0932553..81b1872 100644
--- a/src/Vervis/Federation/Discussion.hs
+++ b/src/Vervis/Federation/Discussion.hs
@@ -16,6 +16,7 @@
module Vervis.Federation.Discussion
( sharerCreateNoteF
, projectCreateNoteF
+ , repoCreateNoteF
)
where
@@ -72,6 +73,7 @@ import Vervis.Model
import Vervis.Model.Ident
import Vervis.Settings
import Vervis.Ticket
+import Vervis.Patch
-- | Check the note in the remote Create Note activity delivered to us.
checkNote
@@ -256,12 +258,21 @@ sharerCreateNoteF now shrRecip author body note = do
case mractid of
Nothing -> "I already have this activity in my inbox, doing nothing"
Just _ -> "Context is remote, so just inserting to my inbox"
- Left (NoteContextSharerTicket shr talid) -> do
+ Left (NoteContextSharerTicket shr talid patch) -> do
mremotesHttp <- runDBExcept $ do
(sid, pid, ibid) <- lift getRecip404
- (Entity _ tal, Entity _ lt, _, _) <- do
- mticket <- lift $ getSharerTicket shr talid
- fromMaybeE mticket "Context: No such sharer-ticket"
+ (tal, lt, followers) <-
+ if patch
+ then do
+ (Entity _ tal, Entity _ lt, _, _, _) <- do
+ mticket <- lift $ getSharerPatch shr talid
+ fromMaybeE mticket "Context: No such sharer-patch"
+ return (tal, lt, LocalPersonCollectionSharerPatchFollowers)
+ else do
+ (Entity _ tal, Entity _ lt, _, _) <- do
+ mticket <- lift $ getSharerTicket shr talid
+ fromMaybeE mticket "Context: No such sharer-ticket"
+ return (tal, lt, LocalPersonCollectionSharerTicketFollowers)
if ticketAuthorLocalAuthor tal == pid
then do
mractid <- lift $ insertToInbox now author body ibid luCreate True
@@ -283,7 +294,7 @@ sharerCreateNoteF now shrRecip author body note = do
let sieve =
makeRecipientSet
[]
- [ LocalPersonCollectionSharerTicketFollowers shrRecip talkhid
+ [ followers shrRecip talkhid
--, LocalPersonCollectionSharerTicketTeam shrRecip talkhid
]
remoteRecips <- insertRemoteActivityToLocalInboxes False ractid $ localRecipSieve' sieve False False localRecips
@@ -315,6 +326,20 @@ sharerCreateNoteF now shrRecip author body note = do
case mractid of
Nothing -> "I already have this activity in my inbox, doing nothing"
Just _ -> "Context is a project-ticket, so just inserting to my inbox"
+ Left (NoteContextRepoPatch shr rp ltid) -> runDBExcept $ do
+ personRecip <- lift $ do
+ sid <- getKeyBy404 $ UniqueSharer shrRecip
+ getValBy404 $ UniquePersonIdent sid
+ (_, _, _, Entity _ lt, _, _, _, _) <- do
+ mticket <- lift $ getRepoPatch shr rp ltid
+ fromMaybeE mticket "Context: No such repo-patch"
+ let did = localTicketDiscuss lt
+ _ <- traverse (getParent did) mparent
+ mractid <- lift $ insertToInbox now author body (personInbox personRecip) luCreate True
+ return $
+ case mractid of
+ Nothing -> "I already have this activity in my inbox, doing nothing"
+ Just _ -> "Context is a repo-patch, so just inserting to my inbox"
where
getRecip404 = do
sid <- getKeyBy404 $ UniqueSharer shrRecip
@@ -361,7 +386,7 @@ projectCreateNoteF now shrRecip prjRecip author body note = do
msig <- checkForward $ LocalActorProject shrRecip prjRecip
case context of
Right _ -> return "Not using; context isn't local"
- Left (NoteContextSharerTicket shr talid) -> do
+ Left (NoteContextSharerTicket shr talid False) -> do
mremotesHttp <- runDBExcept $ do
(jid, ibid) <- lift getProjectRecip404
(_, _, _, project) <- do
@@ -396,6 +421,7 @@ projectCreateNoteF now shrRecip prjRecip author body note = do
Right (sig, remotesHttp) -> do
forkWorker "projectCreateNoteF inbox forwarding by http" $ deliverRemoteHTTP_J now shrRecip prjRecip (actbBL body) sig remotesHttp
return "Stored to inbox and did inbox forwarding"
+ Left (NoteContextSharerTicket _ _ True) -> return "Context is a sharer-patch, ignoring activity"
Left (NoteContextProjectTicket shr prj ltid) -> do
mremotesHttp <- runDBExcept $ do
(jid, ibid) <- lift getProjectRecip404
@@ -436,8 +462,112 @@ projectCreateNoteF now shrRecip prjRecip author body note = do
Right (sig, remotesHttp) -> do
forkWorker "projectCreateNoteF inbox forwarding by http" $ deliverRemoteHTTP_J now shrRecip prjRecip (actbBL body) sig remotesHttp
return "Stored to inbox, cached comment, and did inbox forwarding"
+ Left (NoteContextRepoPatch _ _ _) -> return "Context is a repo-patch, ignoring activity"
where
getProjectRecip404 = do
sid <- getKeyBy404 $ UniqueSharer shrRecip
Entity jid j <- getBy404 $ UniqueProject prjRecip sid
return (jid, projectInbox j)
+
+repoCreateNoteF
+ :: UTCTime
+ -> ShrIdent
+ -> RpIdent
+ -> RemoteAuthor
+ -> ActivityBody
+ -> Note URIMode
+ -> ExceptT Text Handler Text
+repoCreateNoteF now shrRecip rpRecip author body note = do
+ luCreate <-
+ fromMaybeE (activityId $ actbActivity body) "Create without 'id'"
+ (luNote, published, context, mparent, source, content) <- checkNote note
+ (localRecips, _remoteRecips) <- do
+ mrecips <- parseAudience $ activityAudience $ actbActivity body
+ fromMaybeE mrecips "Create Note with no recipients"
+ msig <- checkForward $ LocalActorRepo shrRecip rpRecip
+ case context of
+ Right _ -> return "Not using; context isn't local"
+ Left (NoteContextSharerTicket _ _ False) ->
+ return "Context is a sharer-ticket, ignoring activity"
+ Left (NoteContextSharerTicket shr talid True) -> do
+ mremotesHttp <- runDBExcept $ do
+ (rid, ibid) <- lift getRepoRecip404
+ (_, _, _, repo, _) <- do
+ mticket <- lift $ getSharerPatch shr talid
+ fromMaybeE mticket "Context: No such sharer-ticket"
+ case repo of
+ Left (_, Entity _ trl)
+ | ticketRepoLocalRepo trl == rid -> do
+ mractid <- lift $ insertToInbox now author body ibid luCreate False
+ case mractid of
+ Nothing -> return $ Left "Activity already in my inbox"
+ Just ractid ->
+ case msig of
+ Nothing ->
+ return $ Left
+ "Context is a sharer-patch, \
+ \but no inbox forwarding \
+ \header for me, so doing \
+ \nothing, just storing in inbox"
+ Just sig -> lift $ Right <$> do
+ let sieve =
+ makeRecipientSet
+ []
+ [ LocalPersonCollectionRepoFollowers shrRecip rpRecip
+ , LocalPersonCollectionRepoTeam shrRecip rpRecip
+ ]
+ remoteRecips <- insertRemoteActivityToLocalInboxes False ractid $ localRecipSieve' sieve False False localRecips
+ (sig,) <$> deliverRemoteDB_R (actbBL body) ractid rid sig remoteRecips
+ _ -> return $ Left "Context is a sharer-patch of another repo"
+ case mremotesHttp of
+ Left msg -> return msg
+ Right (sig, remotesHttp) -> do
+ forkWorker "repoCreateNoteF inbox forwarding by http" $ deliverRemoteHTTP_R now shrRecip rpRecip (actbBL body) sig remotesHttp
+ return "Stored to inbox and did inbox forwarding"
+ Left (NoteContextProjectTicket _ _ _) ->
+ return "Context is a project-ticket, ignoring activity"
+ Left (NoteContextRepoPatch shr rp ltid) -> do
+ mremotesHttp <- runDBExcept $ do
+ (rid, ibid) <- lift getRepoRecip404
+ (_, _, _, Entity _ lt, _, Entity _ trl, _, _) <- do
+ mticket <- lift $ getRepoPatch shr rp ltid
+ fromMaybeE mticket "Context: No such repo-patch"
+ if ticketRepoLocalRepo trl == rid
+ then do
+ mractid <- lift $ insertToInbox now author body ibid luCreate False
+ case mractid of
+ Nothing -> return $ Left "Activity already in my inbox"
+ Just ractid -> do
+ let did = localTicketDiscuss lt
+ meparent <- traverse (getParent did) mparent
+ mmid <- lift $ insertToDiscussion author luNote published source content did meparent ractid
+ case mmid of
+ Nothing -> return $ Left "I already have this comment, just storing in inbox"
+ Just mid -> lift $ do
+ updateOrphans author luNote did mid
+ case msig of
+ Nothing ->
+ return $ Left "Storing in inbox, caching comment, no inbox forwarding header"
+ Just sig -> Right <$> do
+ ltkhid <- encodeKeyHashid ltid
+ let sieve =
+ makeRecipientSet
+ []
+ [ LocalPersonCollectionRepoFollowers shrRecip rpRecip
+ , LocalPersonCollectionRepoTeam shrRecip rpRecip
+ , LocalPersonCollectionRepoPatchFollowers shrRecip rpRecip ltkhid
+ --, LocalPersonCollectionProjectTicketTeam shrRecip prjRecip ltkhid
+ ]
+ remoteRecips <- insertRemoteActivityToLocalInboxes False ractid $ localRecipSieve' sieve False False localRecips
+ (sig,) <$> deliverRemoteDB_R (actbBL body) ractid rid sig remoteRecips
+ else return $ Left "Context is a repo-patch of another repo"
+ case mremotesHttp of
+ Left msg -> return msg
+ Right (sig, remotesHttp) -> do
+ forkWorker "repoCreateNoteF inbox forwarding by http" $ deliverRemoteHTTP_R now shrRecip rpRecip (actbBL body) sig remotesHttp
+ return "Stored to inbox, cached comment, and did inbox forwarding"
+ where
+ getRepoRecip404 = do
+ sid <- getKeyBy404 $ UniqueSharer shrRecip
+ Entity rid r <- getBy404 $ UniqueRepo rpRecip sid
+ return (rid, repoInbox r)