diff --git a/src/Vervis/API.hs b/src/Vervis/API.hs
index c2b54ce..a35fddc 100644
--- a/src/Vervis/API.hs
+++ b/src/Vervis/API.hs
@@ -1868,7 +1868,7 @@ inviteC (Entity senderPersonID senderPerson) senderActor muCap summary audience
case capID of
Left (actor, _, item) -> return (actor, item)
Right _ -> throwE "Capability is a remote URI, i.e. not authored by the local topic"
- verifyCapability capability senderPersonID $ bmap entityKey r
+ verifyCapability capability (Left senderPersonID) (bmap entityKey r)
Right _ -> pure ()
-- Insert new Collab to DB
diff --git a/src/Vervis/Access.hs b/src/Vervis/Access.hs
index f7da060..7df7099 100644
--- a/src/Vervis/Access.hs
+++ b/src/Vervis/Access.hs
@@ -84,6 +84,7 @@ import Control.Monad.Trans.Except
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Reader
import Data.Barbie
+import Data.Bifunctor
import Data.Foldable
import Data.Maybe
import Data.Text (Text)
@@ -97,6 +98,7 @@ import Yesod.Hashids
import Yesod.MonadSite
import Control.Monad.Trans.Except.Local
+import Data.Either.Local
import Database.Persist.Local
import Vervis.ActivityPub
@@ -304,10 +306,10 @@ grantResourceLocalActor (GrantResourceLoom l) = LocalActorLoom l
verifyCapability
:: (LocalActorBy Key, OutboxItemId)
- -> PersonId
+ -> Either PersonId RemoteActorId
-> GrantResourceBy Key
-> ExceptT Text (ReaderT SqlBackend Handler) ()
-verifyCapability (capActor, capItem) personID resource = do
+verifyCapability (capActor, capItem) actor resource = do
-- Find the activity itself by URI in the DB
nameExceptT "Capability activity not found" $
@@ -320,16 +322,17 @@ verifyCapability (capActor, capItem) personID resource = do
fromMaybeE maybeEnable "No CollabEnable for this activity"
-- Find the recipient of that Collab
- recipID <- do
- mcrl <- lift $ getValBy $ UniqueCollabRecipLocal collabID
- crl <- fromMaybeE mcrl "No local recip for capability"
- mcrr <- lift $ getBy $ UniqueCollabRecipRemote collabID
- for_ mcrr $ \ _ -> error "Both local & remote recip for capability!"
- return $ collabRecipLocalPerson crl
+ recipID <-
+ lift $ bimap collabRecipLocalPerson collabRecipRemoteActor <$>
+ requireEitherAlt
+ (getValBy $ UniqueCollabRecipLocal collabID)
+ (getValBy $ UniqueCollabRecipRemote collabID)
+ "No collab recip"
+ "Both local and remote recips for collab"
-- Verify the recipient is the expected one
- unless (recipID == personID) $
- throwE "Collab recipient is some other Person"
+ unless (recipID == actor) $
+ throwE "Collab recipient is someone else"
-- Find the local topic, on which this Collab gives access
topic <- lift $ do
diff --git a/src/Vervis/Application.hs b/src/Vervis/Application.hs
index 3ba6f08..1372d57 100644
--- a/src/Vervis/Application.hs
+++ b/src/Vervis/Application.hs
@@ -94,7 +94,7 @@ import Web.Hashids.Local
import Vervis.ActorKey (generateActorKey, actorKeyRotator)
import Vervis.Darcs
-import Vervis.Federation
+import Vervis.Delivery
import Vervis.Foundation
import Vervis.Git
import Vervis.Hook
diff --git a/src/Vervis/Delivery.hs b/src/Vervis/Delivery.hs
index 8e512ed..0e05ce0 100644
--- a/src/Vervis/Delivery.hs
+++ b/src/Vervis/Delivery.hs
@@ -13,13 +13,19 @@
- .
-}
+-- These are for Barbie-related generated instances for ForwarderBy
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+
module Vervis.Delivery
( deliverHttp
, deliverHttpBL
, deliverRemoteDB_D
+ , deliverRemoteDB_L
, deliverRemoteDB_P
, deliverRemoteDB_R
, deliverRemoteHTTP_D
+ , deliverRemoteHTTP_L
, deliverRemoteHTTP_P
, deliverRemoteHTTP_R
, deliverRemoteDB'
@@ -29,6 +35,8 @@ module Vervis.Delivery
, deliverLocal'
, deliverLocal
, insertRemoteActivityToLocalInboxes
+ , fixRunningDeliveries
+ , retryOutboxDelivery
)
where
@@ -42,6 +50,7 @@ import Control.Monad.Trans.Class
import Control.Monad.Trans.Except
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Reader
+import Data.Barbie
import Data.Bifunctor
import Data.Bitraversable
import Data.ByteString (ByteString)
@@ -57,6 +66,7 @@ import Data.Time.Clock
import Data.Traversable
import Database.Persist
import Database.Persist.Sql
+import GHC.Generics
import Network.HTTP.Client
import Network.TLS -- hiding (SHA256)
import Text.Blaze.Html (preEscapedToHtml)
@@ -90,6 +100,7 @@ import qualified Web.ActivityPub as AP
import Control.Monad.Trans.Except.Local
import Data.Either.Local
import Data.List.NonEmpty.Local
+import Data.Maybe.Local
import Data.Patch.Local hiding (Patch)
import Data.Tuple.Local
import Database.Persist.Local
@@ -162,6 +173,17 @@ deliverRemoteDB_D
[((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId, ForwarderDeckId))]
deliverRemoteDB_D = deliverRemoteDB_ ForwarderDeck
+deliverRemoteDB_L
+ :: MonadIO m
+ => BL.ByteString
+ -> RemoteActivityId
+ -> LoomId
+ -> ByteString
+ -> [((InstanceId, Host), NonEmpty RemoteRecipient)]
+ -> ReaderT SqlBackend m
+ [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId, ForwarderLoomId))]
+deliverRemoteDB_L = deliverRemoteDB_ ForwarderLoom
+
deliverRemoteDB_P
:: MonadIO m
=> BL.ByteString
@@ -244,6 +266,17 @@ deliverRemoteHTTP_D
deliverRemoteHTTP_D now dkhid =
deliverRemoteHTTP' now $ LocalActorDeck dkhid
+deliverRemoteHTTP_L
+ :: (MonadSite m, SiteEnv m ~ App)
+ => UTCTime
+ -> KeyHashid Loom
+ -> BL.ByteString
+ -> ByteString
+ -> [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId, ForwarderLoomId))]
+ -> m ()
+deliverRemoteHTTP_L now lkhid =
+ deliverRemoteHTTP' now $ LocalActorLoom lkhid
+
deliverRemoteHTTP_P
:: (MonadSite m, SiteEnv m ~ App)
=> UTCTime
@@ -806,3 +839,429 @@ insertRemoteActivityToLocalInboxes requireOwner ractid =
insertActivityToLocalInboxes makeItem requireOwner Nothing Nothing
where
makeItem ibid ibiid = InboxItemRemote ibid ractid ibiid
+
+fixRunningDeliveries :: (MonadIO m, MonadLogger m, IsSqlBackend backend) => ReaderT backend m ()
+fixRunningDeliveries = do
+ c <- updateWhereCount [UnlinkedDeliveryRunning ==. True] [UnlinkedDeliveryRunning =. False]
+ unless (c == 0) $ logWarn $ T.concat
+ [ "fixRunningDeliveries fixed "
+ , T.pack (show c)
+ , " linked deliveries"
+ ]
+ c' <- updateWhereCount [DeliveryRunning ==. True] [DeliveryRunning =. False]
+ unless (c' == 0) $ logWarn $ T.concat
+ [ "fixRunningDeliveries fixed "
+ , T.pack (show c')
+ , " unlinked deliveries"
+ ]
+ c'' <- updateWhereCount [ForwardingRunning ==. True] [ForwardingRunning =. False]
+ unless (c'' == 0) $ logWarn $ T.concat
+ [ "fixRunningDeliveries fixed "
+ , T.pack (show c'')
+ , " forwarding deliveries"
+ ]
+
+data ForwarderBy f
+ = FwderPerson (f ForwarderPerson)
+ | FwderGroup (f ForwarderGroup)
+ | FwderRepo (f ForwarderRepo)
+ | FwderDeck (f ForwarderDeck)
+ | FwderLoom (f ForwarderLoom)
+ deriving (Generic, FunctorB, ConstraintsB)
+
+partitionFwders
+ :: [ForwarderBy f]
+ -> ( [f ForwarderPerson]
+ , [f ForwarderGroup]
+ , [f ForwarderRepo]
+ , [f ForwarderDeck]
+ , [f ForwarderLoom]
+ )
+partitionFwders = foldl' f ([], [], [], [], [])
+ where
+ f (ps, gs, rs, ds, ls) = \ fwder ->
+ case fwder of
+ FwderPerson p -> (p : ps, gs, rs, ds, ls)
+ FwderGroup g -> (ps, g : gs, rs, ds, ls)
+ FwderRepo r -> (ps, gs, r : rs, ds, ls)
+ FwderDeck d -> (ps, gs, rs, d : ds, ls)
+ FwderLoom l -> (ps, gs, rs, ds, l : ls)
+
+retryOutboxDelivery :: Worker ()
+retryOutboxDelivery = do
+ logInfo "Periodic delivery starting"
+ now <- liftIO $ getCurrentTime
+ (unlinkedHttp, linkedHttp, forwardingHttp) <- runSiteDB $ do
+
+ -- Get all unlinked deliveries which aren't running already in outbox
+ -- post handlers
+ unlinked' <- E.select $ E.from $ \ (udl `E.InnerJoin` ob `E.InnerJoin` ura `E.InnerJoin` ro `E.InnerJoin` i `E.LeftOuterJoin` ra `E.LeftOuterJoin` rc) -> do
+ E.on $ E.just (ro E.^. RemoteObjectId) E.==. rc E.?. RemoteCollectionIdent
+ E.on $ E.just (ro E.^. RemoteObjectId) E.==. ra E.?. RemoteActorIdent
+ E.on $ ro E.^. RemoteObjectInstance E.==. i E.^. InstanceId
+ E.on $ ura E.^. UnfetchedRemoteActorIdent E.==. ro E.^. RemoteObjectId
+ E.on $ udl E.^. UnlinkedDeliveryRecipient E.==. ura E.^. UnfetchedRemoteActorId
+ E.on $ udl E.^. UnlinkedDeliveryActivity E.==. ob E.^. OutboxItemId
+ E.where_ $ udl E.^. UnlinkedDeliveryRunning E.==. E.val False
+ E.orderBy [E.asc $ ro E.^. RemoteObjectInstance, E.asc $ ura E.^. UnfetchedRemoteActorId]
+ return
+ ( i E.^. InstanceId
+ , i E.^. InstanceHost
+ , ura E.^. UnfetchedRemoteActorId
+ , ro E.^. RemoteObjectIdent
+ , ura E.^. UnfetchedRemoteActorSince
+ , udl E.^. UnlinkedDeliveryId
+ , udl E.^. UnlinkedDeliveryActivity
+ , udl E.^. UnlinkedDeliveryForwarding
+ , ob E.^. OutboxItemActivity
+ , ra E.?. RemoteActorId
+ , rc E.?. RemoteCollectionId
+ )
+
+ -- Strip the E.Value wrappers and organize the records for the
+ -- filtering and grouping we'll need to do
+ let unlinked = map adaptUnlinked unlinked'
+
+ -- Split into found (recipient has been reached) and lonely (recipient
+ -- hasn't been reached
+ (found, lonely) = partitionMaybes unlinked
+
+ -- Turn the found ones into linked deliveries
+ deleteWhere [UnlinkedDeliveryId <-. map (unlinkedID . snd) found]
+ insertMany_ $ mapMaybe toLinked found
+
+ -- We're left with the lonely ones. We'll check which actors have been
+ -- unreachable for too long, and we'll delete deliveries for them. The
+ -- rest of the actors we'll try to reach by HTTP.
+ dropAfter <- lift $ asksSite $ appDropDeliveryAfter . appSettings
+ let (lonelyOld, lonelyNew) =
+ partitionEithers $ map (decideBySinceUDL dropAfter now) lonely
+ deleteWhere [UnlinkedDeliveryId <-. lonelyOld]
+
+ -- Now let's grab the linked deliveries, and similarly delete old ones
+ -- and return the rest for HTTP delivery.
+ linked <- E.select $ E.from $ \ (dl `E.InnerJoin` ra `E.InnerJoin` ro `E.InnerJoin` i `E.InnerJoin` ob) -> do
+ E.on $ dl E.^. DeliveryActivity E.==. ob E.^. OutboxItemId
+ E.on $ ro E.^. RemoteObjectInstance E.==. i E.^. InstanceId
+ E.on $ ra E.^. RemoteActorIdent E.==. ro E.^. RemoteObjectId
+ E.on $ dl E.^. DeliveryRecipient E.==. ra E.^. RemoteActorId
+ E.where_ $ dl E.^. DeliveryRunning E.==. E.val False
+ E.orderBy [E.asc $ ro E.^. RemoteObjectInstance, E.asc $ ra E.^. RemoteActorId]
+ return
+ ( i E.^. InstanceId
+ , i E.^. InstanceHost
+ , ra E.^. RemoteActorId
+ , ro E.^. RemoteObjectIdent
+ , ra E.^. RemoteActorInbox
+ , ra E.^. RemoteActorErrorSince
+ , dl E.^. DeliveryId
+ , dl E.^. DeliveryForwarding
+ , ob E.^. OutboxItemActivity
+ )
+ let (linkedOld, linkedNew) =
+ partitionEithers $
+ map (decideBySinceDL dropAfter now . adaptLinked) linked
+ deleteWhere [DeliveryId <-. linkedOld]
+
+ -- Same for forwarding deliveries, which are always linked
+ forwarding <- E.select $ E.from $
+ \ (fw `E.InnerJoin` ra `E.InnerJoin` ro `E.InnerJoin` i
+ `E.LeftOuterJoin` fwp
+ `E.LeftOuterJoin` fwg
+ `E.LeftOuterJoin` fwr
+ `E.LeftOuterJoin` fwd
+ `E.LeftOuterJoin` fwl
+ ) -> do
+ E.on $ E.just (fw E.^. ForwardingId) E.==. fwl E.?. ForwarderLoomTask
+ E.on $ E.just (fw E.^. ForwardingId) E.==. fwd E.?. ForwarderDeckTask
+ E.on $ E.just (fw E.^. ForwardingId) E.==. fwr E.?. ForwarderRepoTask
+ E.on $ E.just (fw E.^. ForwardingId) E.==. fwg E.?. ForwarderGroupTask
+ E.on $ E.just (fw E.^. ForwardingId) E.==. fwp E.?. ForwarderPersonTask
+ E.on $ ro E.^. RemoteObjectInstance E.==. i E.^. InstanceId
+ E.on $ ra E.^. RemoteActorIdent E.==. ro E.^. RemoteObjectId
+ E.on $ fw E.^. ForwardingRecipient E.==. ra E.^. RemoteActorId
+ E.where_ $ fw E.^. ForwardingRunning E.==. E.val False
+ E.orderBy [E.asc $ ro E.^. RemoteObjectInstance, E.asc $ ra E.^. RemoteActorId]
+ return (i, ra, fw, fwp, fwg, fwr, fwd, fwl)
+ let (forwardingOld, forwardingNew) =
+ partitionEithers $
+ map (decideBySinceFW dropAfter now . adaptForwarding)
+ forwarding
+ (fwidsOld, fwdersOld) = unzip forwardingOld
+ (fwpidsOld, fwgidsOld, fwridsOld, fwdidsOld, fwlidsOld) =
+ partitionFwders fwdersOld
+ deleteWhere [ForwarderPersonId <-. fwpidsOld]
+ deleteWhere [ForwarderGroupId <-. fwgidsOld]
+ deleteWhere [ForwarderRepoId <-. fwridsOld]
+ deleteWhere [ForwarderDeckId <-. fwdidsOld]
+ deleteWhere [ForwarderLoomId <-. fwlidsOld]
+ deleteWhere [ForwardingId <-. fwidsOld]
+
+ return
+ ( groupUnlinked lonelyNew
+ , groupLinked linkedNew
+ , groupForwarding forwardingNew
+ )
+
+ let deliver = deliverHttpBL
+ logInfo "Periodic delivery prepared DB, starting async HTTP POSTs"
+
+ logDebug $
+ "Periodic delivery forking linked " <>
+ T.pack (show $ map (renderAuthority . snd . fst) linkedHttp)
+ waitsDL <- traverse (fork . deliverLinked deliver now) linkedHttp
+
+ logDebug $
+ "Periodic delivery forking forwarding " <>
+ T.pack (show $ map (renderAuthority . snd . fst) forwardingHttp)
+ waitsFW <- traverse (fork . deliverForwarding now) forwardingHttp
+
+ logDebug $
+ "Periodic delivery forking unlinked " <>
+ T.pack (show $ map (renderAuthority . snd . fst) unlinkedHttp)
+ waitsUDL <- traverse (fork . deliverUnlinked deliver now) unlinkedHttp
+
+ logDebug $
+ T.concat
+ [ "Periodic delivery waiting for ", T.pack $ show $ length waitsDL
+ , " linked"
+ ]
+ resultsDL <- sequence waitsDL
+ unless (and resultsDL) $ logError "Periodic delivery DL error"
+
+ logDebug $
+ T.concat
+ [ "Periodic delivery waiting for ", T.pack $ show $ length waitsFW
+ , " forwarding"
+ ]
+ resultsFW <- sequence waitsFW
+ unless (and resultsFW) $ logError "Periodic delivery FW error"
+
+ logDebug $
+ T.concat
+ [ "Periodic delivery waiting for "
+ , T.pack $ show $ length waitsUDL, " unlinked"
+ ]
+ resultsUDL <- sequence waitsUDL
+ unless (and resultsUDL) $ logError "Periodic delivery UDL error"
+
+ logInfo "Periodic delivery done"
+ where
+ adaptUnlinked
+ (E.Value iid, E.Value h, E.Value uraid, E.Value luRecip, E.Value since, E.Value udlid, E.Value obid, E.Value fwd, E.Value act, E.Value mraid, E.Value mrcid) =
+ ( Left <$> mraid <|> Right <$> mrcid
+ , ( ( (iid, h)
+ , ((uraid, luRecip), (udlid, fwd, obid, BL.fromStrict $ persistJSONBytes act))
+ )
+ , since
+ )
+ )
+
+ unlinkedID ((_, (_, (udlid, _, _, _))), _) = udlid
+
+ toLinked (Left raid, ((_, (_, (_, fwd, obid, _))), _)) = Just $ Delivery raid obid fwd False
+ toLinked (Right _ , _ ) = Nothing
+
+ relevant dropAfter now since = addUTCTime dropAfter since > now
+
+ decideBySinceUDL dropAfter now (udl@(_, (_, (udlid, _, _, _))), msince) =
+ case msince of
+ Nothing -> Right udl
+ Just since ->
+ if relevant dropAfter now since
+ then Right udl
+ else Left udlid
+
+ adaptLinked
+ (E.Value iid, E.Value h, E.Value raid, E.Value ident, E.Value inbox, E.Value since, E.Value dlid, E.Value fwd, E.Value act) =
+ ( ( (iid, h)
+ , ((raid, (ident, inbox)), (dlid, fwd, BL.fromStrict $ persistJSONBytes act))
+ )
+ , since
+ )
+
+ decideBySinceDL dropAfter now (dl@(_, (_, (dlid, _, _))), msince) =
+ case msince of
+ Nothing -> Right dl
+ Just since ->
+ if relevant dropAfter now since
+ then Right dl
+ else Left dlid
+
+ adaptForwarding
+ ( Entity iid (Instance h)
+ , Entity raid (RemoteActor _ _ inbox _ since)
+ , Entity fwid (Forwarding _ _ body sig _)
+ , mfwp, mfwg, mfwr, mfwd, mfwl
+ ) =
+ ( ( (iid, h)
+ , ( (raid, inbox)
+ , ( fwid
+ , BL.fromStrict body
+ , case (mfwp, mfwg, mfwr, mfwd, mfwl) of
+ (Nothing, Nothing, Nothing, Nothing, Nothing) ->
+ error "Found fwid without a Forwarder* record"
+ (Just fwp, Nothing, Nothing, Nothing, Nothing) ->
+ FwderPerson fwp
+ (Nothing, Just fwg, Nothing, Nothing, Nothing) ->
+ FwderGroup fwg
+ (Nothing, Nothing, Just fwr, Nothing, Nothing) ->
+ FwderRepo fwr
+ (Nothing, Nothing, Nothing, Just fwd, Nothing) ->
+ FwderDeck fwd
+ (Nothing, Nothing, Nothing, Nothing, Just fwl) ->
+ FwderLoom fwl
+ _ -> error "Found fwid with multiple forwarders"
+ , sig
+ )
+ )
+ )
+ , since
+ )
+
+ decideBySinceFW dropAfter now (fw@(_, (_, (fwid, _, fwder, _))), msince) =
+ case msince of
+ Nothing -> Right fw
+ Just since ->
+ if relevant dropAfter now since
+ then Right fw
+ else Left (fwid, bmap entityKey fwder)
+
+ groupUnlinked
+ = map (second $ groupWithExtractBy1 ((==) `on` fst) fst snd)
+ . groupWithExtractBy ((==) `on` fst) fst snd
+
+ groupLinked
+ = map (second $ groupWithExtractBy1 ((==) `on` fst) fst snd)
+ . groupWithExtractBy ((==) `on` fst) fst snd
+
+ groupForwarding
+ = map (second $ groupWithExtractBy1 ((==) `on` fst) fst snd)
+ . groupWithExtractBy ((==) `on` fst) fst snd
+
+ fork action = do
+ wait <- asyncWorker action
+ return $ do
+ result <- wait
+ case result of
+ Left e -> do
+ logError $ "Periodic delivery error! " <> T.pack (displayException e)
+ return False
+ Right success -> return success
+
+ deliverLinked deliver now ((_, h), recips) = do
+ logDebug $ "Periodic deliver starting linked for host " <> renderAuthority h
+ waitsR <- for recips $ \ ((raid, (ident, inbox)), delivs) -> fork $ do
+ logDebug $
+ "Periodic deliver starting linked for actor " <>
+ renderObjURI (ObjURI h ident)
+ waitsD <- for delivs $ \ (dlid, fwd, doc) -> fork $ do
+ let fwd' = if fwd then Just ident else Nothing
+ e <- deliver doc fwd' h inbox
+ case e of
+ Left err -> do
+ logError $ T.concat
+ [ "Periodic DL delivery #", T.pack $ show dlid
+ , " error for <", renderObjURI $ ObjURI h ident, ">: "
+ , T.pack $ displayException err
+ ]
+ return False
+ Right _resp -> do
+ runSiteDB $ delete dlid
+ return True
+ results <- sequence waitsD
+ runSiteDB $
+ if and results
+ then update raid [RemoteActorErrorSince =. Nothing]
+ else if or results
+ then update raid [RemoteActorErrorSince =. Just now]
+ else updateWhere [RemoteActorId ==. raid, RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now]
+ return True
+ results <- sequence waitsR
+ unless (and results) $
+ logError $ "Periodic DL delivery error for host " <> renderAuthority h
+ return True
+
+ deliverUnlinked deliver now ((iid, h), recips) = do
+ logDebug $ "Periodic deliver starting unlinked for host " <> renderAuthority h
+ waitsR <- for recips $ \ ((uraid, luRecip), delivs) -> fork $ do
+ logDebug $
+ "Periodic deliver starting unlinked for actor " <>
+ renderObjURI (ObjURI h luRecip)
+ e <- fetchRemoteActor iid h luRecip
+ case e of
+ Right (Right mera) ->
+ case mera of
+ Nothing -> runSiteDB $ deleteWhere [UnlinkedDeliveryId <-. map fst4 (NE.toList delivs)]
+ Just (Entity raid ra) -> do
+ waitsD <- for delivs $ \ (udlid, fwd, obid, doc) -> fork $ do
+ let fwd' = if fwd then Just luRecip else Nothing
+ e' <- deliver doc fwd' h $ remoteActorInbox ra
+ case e' of
+ Left _err -> do
+ runSiteDB $ do
+ delete udlid
+ insert_ $ Delivery raid obid fwd False
+ return False
+ Right _resp -> do
+ runSiteDB $ delete udlid
+ return True
+ results <- sequence waitsD
+ runSiteDB $
+ if and results
+ then update raid [RemoteActorErrorSince =. Nothing]
+ else if or results
+ then update raid [RemoteActorErrorSince =. Just now]
+ else updateWhere [RemoteActorId ==. raid, RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now]
+ _ -> runSiteDB $ updateWhere [UnfetchedRemoteActorId ==. uraid, UnfetchedRemoteActorSince ==. Nothing] [UnfetchedRemoteActorSince =. Just now]
+ return True
+ results <- sequence waitsR
+ unless (and results) $
+ logError $ "Periodic UDL delivery error for host " <> renderAuthority h
+ return True
+
+ deliverForwarding now ((_, h), recips) = do
+ logDebug $ "Periodic deliver starting forwarding for host " <> renderAuthority h
+ waitsR <- for recips $ \ ((raid, inbox), delivs) -> fork $ do
+ logDebug $
+ "Periodic deliver starting forwarding for inbox " <>
+ renderObjURI (ObjURI h inbox)
+ waitsD <- for delivs $ \ (fwid, body, fwderE, sig) -> fork $ do
+ let (fwderK, senderK) = splitForwarder fwderE
+ sender <- renderLocalActor <$> hashLocalActor senderK
+ e <- forwardActivity (ObjURI h inbox) sig sender body
+ case e of
+ Left _err -> return False
+ Right _resp -> do
+ runSiteDB $ do
+ case fwderK of
+ FwderPerson k -> delete k
+ FwderGroup k -> delete k
+ FwderRepo k -> delete k
+ FwderDeck k -> delete k
+ FwderLoom k -> delete k
+ delete fwid
+ return True
+ results <- sequence waitsD
+ runSiteDB $
+ if and results
+ then update raid [RemoteActorErrorSince =. Nothing]
+ else if or results
+ then update raid [RemoteActorErrorSince =. Just now]
+ else updateWhere [RemoteActorId ==. raid, RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now]
+ return True
+ results <- sequence waitsR
+ unless (and results) $
+ logError $ "Periodic FW delivery error for host " <> renderAuthority h
+ return True
+ where
+ splitForwarder (FwderPerson (Entity f (ForwarderPerson _ p))) =
+ (FwderPerson f, LocalActorPerson p)
+ splitForwarder (FwderGroup (Entity f (ForwarderGroup _ g))) =
+ (FwderGroup f, LocalActorGroup g)
+ splitForwarder (FwderRepo (Entity f (ForwarderRepo _ r))) =
+ (FwderRepo f, LocalActorRepo r)
+ splitForwarder (FwderDeck (Entity f (ForwarderDeck _ d))) =
+ (FwderDeck f, LocalActorDeck d)
+ splitForwarder (FwderLoom (Entity f (ForwarderLoom _ l))) =
+ (FwderLoom f, LocalActorLoom l)
diff --git a/src/Vervis/Federation.hs b/src/Vervis/Federation.hs
index 49c36b5..2fb5f88 100644
--- a/src/Vervis/Federation.hs
+++ b/src/Vervis/Federation.hs
@@ -13,22 +13,8 @@
- .
-}
--- These are for Barbie-related generated instances for ForwarderBy
-{-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE DeriveGeneric #-}
---{-# LANGUAGE StandaloneDeriving #-}
---{-# LANGUAGE UndecidableInstances #-}
-
module Vervis.Federation
(
- {-
- handlePersonInbox
- , handleDeckInbox
- , handleLoomInbox
- , handleRepoInbox
- -}
- fixRunningDeliveries
- , retryOutboxDelivery
)
where
@@ -169,540 +155,4 @@ handleProjectInbox shrRecip prjRecip now auth body = do
errorLocalForwarded (ActivityAuthLocalRepo rid) =
"Project inbox got local forwarded activity by rid#" <>
T.pack (show $ fromSqlKey rid)
-
-handleDeckInbox
- :: KeyHashid Project
- -> UTCTime
- -> ActivityAuthentication
- -> ActivityBody
- -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
-handleDeckInbox dkkhid now auth body = do
- remoteAuthor <-
- case auth of
- ActivityAuthLocal local -> throwE $ errorLocalForwarded local
- ActivityAuthRemote ra -> return ra
- luActivity <-
- fromMaybeE (activityId $ actbActivity body) "Activity without 'id'"
- localRecips <- do
- mrecips <- parseAudience $ activityAudience $ actbActivity body
- paudLocalRecips <$> fromMaybeE mrecips "Activity with no recipients"
- msig <- checkForwarding $ LocalActorProject shrRecip prjRecip
- let mfwd = (localRecips,) <$> msig
- case activitySpecific $ actbActivity body of
- CreateActivity (Create obj mtarget) ->
- case obj of
- CreateNote _ note ->
- (,Nothing) <$> projectCreateNoteF now shrRecip prjRecip remoteAuthor body mfwd luActivity note
- CreateTicket _ ticket ->
- (,Nothing) <$> projectCreateTicketF now shrRecip prjRecip remoteAuthor body mfwd luActivity ticket mtarget
- _ -> error "Unsupported create object type for projects"
- FollowActivity follow ->
- (,Nothing) <$> projectFollowF shrRecip prjRecip now remoteAuthor body mfwd luActivity follow
- OfferActivity (Offer obj target) ->
- case obj of
- OfferTicket ticket ->
- (,Nothing) <$> projectOfferTicketF now shrRecip prjRecip remoteAuthor body mfwd luActivity ticket target
- OfferDep dep ->
- projectOfferDepF now shrRecip prjRecip remoteAuthor body mfwd luActivity dep target
- _ -> return ("Unsupported offer object type for projects", Nothing)
- ResolveActivity resolve ->
- (,Nothing) <$> projectResolveF now shrRecip prjRecip remoteAuthor body mfwd luActivity resolve
- UndoActivity undo ->
- (,Nothing) <$> projectUndoF shrRecip prjRecip now remoteAuthor body mfwd luActivity undo
- _ -> return ("Unsupported activity type for projects", Nothing)
- where
- errorLocalForwarded (ActivityAuthLocalPerson pid) =
- "Project inbox got local forwarded activity by pid#" <>
- T.pack (show $ fromSqlKey pid)
- errorLocalForwarded (ActivityAuthLocalProject jid) =
- "Project inbox got local forwarded activity by jid#" <>
- T.pack (show $ fromSqlKey jid)
- errorLocalForwarded (ActivityAuthLocalRepo rid) =
- "Project inbox got local forwarded activity by rid#" <>
- T.pack (show $ fromSqlKey rid)
-
-handleRepoInbox
- :: ShrIdent
- -> RpIdent
- -> UTCTime
- -> ActivityAuthentication
- -> ActivityBody
- -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
-handleRepoInbox shrRecip rpRecip now auth body = do
- remoteAuthor <-
- case auth of
- ActivityAuthLocal local -> throwE $ errorLocalForwarded local
- ActivityAuthRemote ra -> return ra
- luActivity <-
- fromMaybeE (activityId $ actbActivity body) "Activity without 'id'"
- localRecips <- do
- mrecips <- parseAudience $ activityAudience $ actbActivity body
- paudLocalRecips <$> fromMaybeE mrecips "Activity with no recipients"
- msig <- checkForwarding $ LocalActorRepo shrRecip rpRecip
- let mfwd = (localRecips,) <$> msig
- case activitySpecific $ actbActivity body of
- ApplyActivity (AP.Apply uObject uTarget) ->
- repoApplyF now shrRecip rpRecip remoteAuthor body mfwd luActivity uObject uTarget
- AddActivity (AP.Add obj target) ->
- case obj of
- Right (AddBundle patches) ->
- repoAddBundleF now shrRecip rpRecip remoteAuthor body mfwd luActivity patches target
- _ -> return ("Unsupported add object type for repos", Nothing)
- CreateActivity (Create obj mtarget) ->
- case obj of
- CreateNote _ note ->
- (,Nothing) <$> repoCreateNoteF now shrRecip rpRecip remoteAuthor body mfwd luActivity note
- CreateTicket _ ticket ->
- (,Nothing) <$> repoCreateTicketF now shrRecip rpRecip remoteAuthor body mfwd luActivity ticket mtarget
- _ -> error "Unsupported create object type for repos"
- FollowActivity follow ->
- (,Nothing) <$> repoFollowF shrRecip rpRecip now remoteAuthor body mfwd luActivity follow
- OfferActivity (Offer obj target) ->
- case obj of
- OfferTicket ticket ->
- (,Nothing) <$> repoOfferTicketF now shrRecip rpRecip remoteAuthor body mfwd luActivity ticket target
- OfferDep dep ->
- repoOfferDepF now shrRecip rpRecip remoteAuthor body mfwd luActivity dep target
- _ -> return ("Unsupported offer object type for repos", Nothing)
- ResolveActivity resolve ->
- (,Nothing) <$> repoResolveF now shrRecip rpRecip remoteAuthor body mfwd luActivity resolve
- UndoActivity undo->
- (,Nothing) <$> repoUndoF shrRecip rpRecip now remoteAuthor body mfwd luActivity undo
- _ -> return ("Unsupported activity type for repos", Nothing)
- where
- errorLocalForwarded (ActivityAuthLocalPerson pid) =
- "Repo inbox got local forwarded activity by pid#" <>
- T.pack (show $ fromSqlKey pid)
- errorLocalForwarded (ActivityAuthLocalProject jid) =
- "Repo inbox got local forwarded activity by jid#" <>
- T.pack (show $ fromSqlKey jid)
- errorLocalForwarded (ActivityAuthLocalRepo rid) =
- "Repo inbox got local forwarded activity by rid#" <>
- T.pack (show $ fromSqlKey rid)
-}
-
-fixRunningDeliveries :: (MonadIO m, MonadLogger m, IsSqlBackend backend) => ReaderT backend m ()
-fixRunningDeliveries = do
- c <- updateWhereCount [UnlinkedDeliveryRunning ==. True] [UnlinkedDeliveryRunning =. False]
- unless (c == 0) $ logWarn $ T.concat
- [ "fixRunningDeliveries fixed "
- , T.pack (show c)
- , " linked deliveries"
- ]
- c' <- updateWhereCount [DeliveryRunning ==. True] [DeliveryRunning =. False]
- unless (c' == 0) $ logWarn $ T.concat
- [ "fixRunningDeliveries fixed "
- , T.pack (show c')
- , " unlinked deliveries"
- ]
- c'' <- updateWhereCount [ForwardingRunning ==. True] [ForwardingRunning =. False]
- unless (c'' == 0) $ logWarn $ T.concat
- [ "fixRunningDeliveries fixed "
- , T.pack (show c'')
- , " forwarding deliveries"
- ]
-
-data ForwarderBy f
- = FwderPerson (f ForwarderPerson)
- | FwderGroup (f ForwarderGroup)
- | FwderRepo (f ForwarderRepo)
- | FwderDeck (f ForwarderDeck)
- | FwderLoom (f ForwarderLoom)
- deriving (Generic, FunctorB, ConstraintsB)
-
-partitionFwders
- :: [ForwarderBy f]
- -> ( [f ForwarderPerson]
- , [f ForwarderGroup]
- , [f ForwarderRepo]
- , [f ForwarderDeck]
- , [f ForwarderLoom]
- )
-partitionFwders = foldl' f ([], [], [], [], [])
- where
- f (ps, gs, rs, ds, ls) = \ fwder ->
- case fwder of
- FwderPerson p -> (p : ps, gs, rs, ds, ls)
- FwderGroup g -> (ps, g : gs, rs, ds, ls)
- FwderRepo r -> (ps, gs, r : rs, ds, ls)
- FwderDeck d -> (ps, gs, rs, d : ds, ls)
- FwderLoom l -> (ps, gs, rs, ds, l : ls)
-
-retryOutboxDelivery :: Worker ()
-retryOutboxDelivery = do
- logInfo "Periodic delivery starting"
- now <- liftIO $ getCurrentTime
- (unlinkedHttp, linkedHttp, forwardingHttp) <- runSiteDB $ do
-
- -- Get all unlinked deliveries which aren't running already in outbox
- -- post handlers
- unlinked' <- E.select $ E.from $ \ (udl `E.InnerJoin` ob `E.InnerJoin` ura `E.InnerJoin` ro `E.InnerJoin` i `E.LeftOuterJoin` ra `E.LeftOuterJoin` rc) -> do
- E.on $ E.just (ro E.^. RemoteObjectId) E.==. rc E.?. RemoteCollectionIdent
- E.on $ E.just (ro E.^. RemoteObjectId) E.==. ra E.?. RemoteActorIdent
- E.on $ ro E.^. RemoteObjectInstance E.==. i E.^. InstanceId
- E.on $ ura E.^. UnfetchedRemoteActorIdent E.==. ro E.^. RemoteObjectId
- E.on $ udl E.^. UnlinkedDeliveryRecipient E.==. ura E.^. UnfetchedRemoteActorId
- E.on $ udl E.^. UnlinkedDeliveryActivity E.==. ob E.^. OutboxItemId
- E.where_ $ udl E.^. UnlinkedDeliveryRunning E.==. E.val False
- E.orderBy [E.asc $ ro E.^. RemoteObjectInstance, E.asc $ ura E.^. UnfetchedRemoteActorId]
- return
- ( i E.^. InstanceId
- , i E.^. InstanceHost
- , ura E.^. UnfetchedRemoteActorId
- , ro E.^. RemoteObjectIdent
- , ura E.^. UnfetchedRemoteActorSince
- , udl E.^. UnlinkedDeliveryId
- , udl E.^. UnlinkedDeliveryActivity
- , udl E.^. UnlinkedDeliveryForwarding
- , ob E.^. OutboxItemActivity
- , ra E.?. RemoteActorId
- , rc E.?. RemoteCollectionId
- )
-
- -- Strip the E.Value wrappers and organize the records for the
- -- filtering and grouping we'll need to do
- let unlinked = map adaptUnlinked unlinked'
-
- -- Split into found (recipient has been reached) and lonely (recipient
- -- hasn't been reached
- (found, lonely) = partitionMaybes unlinked
-
- -- Turn the found ones into linked deliveries
- deleteWhere [UnlinkedDeliveryId <-. map (unlinkedID . snd) found]
- insertMany_ $ mapMaybe toLinked found
-
- -- We're left with the lonely ones. We'll check which actors have been
- -- unreachable for too long, and we'll delete deliveries for them. The
- -- rest of the actors we'll try to reach by HTTP.
- dropAfter <- lift $ asksSite $ appDropDeliveryAfter . appSettings
- let (lonelyOld, lonelyNew) =
- partitionEithers $ map (decideBySinceUDL dropAfter now) lonely
- deleteWhere [UnlinkedDeliveryId <-. lonelyOld]
-
- -- Now let's grab the linked deliveries, and similarly delete old ones
- -- and return the rest for HTTP delivery.
- linked <- E.select $ E.from $ \ (dl `E.InnerJoin` ra `E.InnerJoin` ro `E.InnerJoin` i `E.InnerJoin` ob) -> do
- E.on $ dl E.^. DeliveryActivity E.==. ob E.^. OutboxItemId
- E.on $ ro E.^. RemoteObjectInstance E.==. i E.^. InstanceId
- E.on $ ra E.^. RemoteActorIdent E.==. ro E.^. RemoteObjectId
- E.on $ dl E.^. DeliveryRecipient E.==. ra E.^. RemoteActorId
- E.where_ $ dl E.^. DeliveryRunning E.==. E.val False
- E.orderBy [E.asc $ ro E.^. RemoteObjectInstance, E.asc $ ra E.^. RemoteActorId]
- return
- ( i E.^. InstanceId
- , i E.^. InstanceHost
- , ra E.^. RemoteActorId
- , ro E.^. RemoteObjectIdent
- , ra E.^. RemoteActorInbox
- , ra E.^. RemoteActorErrorSince
- , dl E.^. DeliveryId
- , dl E.^. DeliveryForwarding
- , ob E.^. OutboxItemActivity
- )
- let (linkedOld, linkedNew) =
- partitionEithers $
- map (decideBySinceDL dropAfter now . adaptLinked) linked
- deleteWhere [DeliveryId <-. linkedOld]
-
- -- Same for forwarding deliveries, which are always linked
- forwarding <- E.select $ E.from $
- \ (fw `E.InnerJoin` ra `E.InnerJoin` ro `E.InnerJoin` i
- `E.LeftOuterJoin` fwp
- `E.LeftOuterJoin` fwg
- `E.LeftOuterJoin` fwr
- `E.LeftOuterJoin` fwd
- `E.LeftOuterJoin` fwl
- ) -> do
- E.on $ E.just (fw E.^. ForwardingId) E.==. fwl E.?. ForwarderLoomTask
- E.on $ E.just (fw E.^. ForwardingId) E.==. fwd E.?. ForwarderDeckTask
- E.on $ E.just (fw E.^. ForwardingId) E.==. fwr E.?. ForwarderRepoTask
- E.on $ E.just (fw E.^. ForwardingId) E.==. fwg E.?. ForwarderGroupTask
- E.on $ E.just (fw E.^. ForwardingId) E.==. fwp E.?. ForwarderPersonTask
- E.on $ ro E.^. RemoteObjectInstance E.==. i E.^. InstanceId
- E.on $ ra E.^. RemoteActorIdent E.==. ro E.^. RemoteObjectId
- E.on $ fw E.^. ForwardingRecipient E.==. ra E.^. RemoteActorId
- E.where_ $ fw E.^. ForwardingRunning E.==. E.val False
- E.orderBy [E.asc $ ro E.^. RemoteObjectInstance, E.asc $ ra E.^. RemoteActorId]
- return (i, ra, fw, fwp, fwg, fwr, fwd, fwl)
- let (forwardingOld, forwardingNew) =
- partitionEithers $
- map (decideBySinceFW dropAfter now . adaptForwarding)
- forwarding
- (fwidsOld, fwdersOld) = unzip forwardingOld
- (fwpidsOld, fwgidsOld, fwridsOld, fwdidsOld, fwlidsOld) =
- partitionFwders fwdersOld
- deleteWhere [ForwarderPersonId <-. fwpidsOld]
- deleteWhere [ForwarderGroupId <-. fwgidsOld]
- deleteWhere [ForwarderRepoId <-. fwridsOld]
- deleteWhere [ForwarderDeckId <-. fwdidsOld]
- deleteWhere [ForwarderLoomId <-. fwlidsOld]
- deleteWhere [ForwardingId <-. fwidsOld]
-
- return
- ( groupUnlinked lonelyNew
- , groupLinked linkedNew
- , groupForwarding forwardingNew
- )
-
- let deliver = deliverHttpBL
- logInfo "Periodic delivery prepared DB, starting async HTTP POSTs"
-
- logDebug $
- "Periodic delivery forking linked " <>
- T.pack (show $ map (renderAuthority . snd . fst) linkedHttp)
- waitsDL <- traverse (fork . deliverLinked deliver now) linkedHttp
-
- logDebug $
- "Periodic delivery forking forwarding " <>
- T.pack (show $ map (renderAuthority . snd . fst) forwardingHttp)
- waitsFW <- traverse (fork . deliverForwarding now) forwardingHttp
-
- logDebug $
- "Periodic delivery forking unlinked " <>
- T.pack (show $ map (renderAuthority . snd . fst) unlinkedHttp)
- waitsUDL <- traverse (fork . deliverUnlinked deliver now) unlinkedHttp
-
- logDebug $
- T.concat
- [ "Periodic delivery waiting for ", T.pack $ show $ length waitsDL
- , " linked"
- ]
- resultsDL <- sequence waitsDL
- unless (and resultsDL) $ logError "Periodic delivery DL error"
-
- logDebug $
- T.concat
- [ "Periodic delivery waiting for ", T.pack $ show $ length waitsFW
- , " forwarding"
- ]
- resultsFW <- sequence waitsFW
- unless (and resultsFW) $ logError "Periodic delivery FW error"
-
- logDebug $
- T.concat
- [ "Periodic delivery waiting for "
- , T.pack $ show $ length waitsUDL, " unlinked"
- ]
- resultsUDL <- sequence waitsUDL
- unless (and resultsUDL) $ logError "Periodic delivery UDL error"
-
- logInfo "Periodic delivery done"
- where
- adaptUnlinked
- (E.Value iid, E.Value h, E.Value uraid, E.Value luRecip, E.Value since, E.Value udlid, E.Value obid, E.Value fwd, E.Value act, E.Value mraid, E.Value mrcid) =
- ( Left <$> mraid <|> Right <$> mrcid
- , ( ( (iid, h)
- , ((uraid, luRecip), (udlid, fwd, obid, BL.fromStrict $ persistJSONBytes act))
- )
- , since
- )
- )
-
- unlinkedID ((_, (_, (udlid, _, _, _))), _) = udlid
-
- toLinked (Left raid, ((_, (_, (_, fwd, obid, _))), _)) = Just $ Delivery raid obid fwd False
- toLinked (Right _ , _ ) = Nothing
-
- relevant dropAfter now since = addUTCTime dropAfter since > now
-
- decideBySinceUDL dropAfter now (udl@(_, (_, (udlid, _, _, _))), msince) =
- case msince of
- Nothing -> Right udl
- Just since ->
- if relevant dropAfter now since
- then Right udl
- else Left udlid
-
- adaptLinked
- (E.Value iid, E.Value h, E.Value raid, E.Value ident, E.Value inbox, E.Value since, E.Value dlid, E.Value fwd, E.Value act) =
- ( ( (iid, h)
- , ((raid, (ident, inbox)), (dlid, fwd, BL.fromStrict $ persistJSONBytes act))
- )
- , since
- )
-
- decideBySinceDL dropAfter now (dl@(_, (_, (dlid, _, _))), msince) =
- case msince of
- Nothing -> Right dl
- Just since ->
- if relevant dropAfter now since
- then Right dl
- else Left dlid
-
- adaptForwarding
- ( Entity iid (Instance h)
- , Entity raid (RemoteActor _ _ inbox _ since)
- , Entity fwid (Forwarding _ _ body sig _)
- , mfwp, mfwg, mfwr, mfwd, mfwl
- ) =
- ( ( (iid, h)
- , ( (raid, inbox)
- , ( fwid
- , BL.fromStrict body
- , case (mfwp, mfwg, mfwr, mfwd, mfwl) of
- (Nothing, Nothing, Nothing, Nothing, Nothing) ->
- error "Found fwid without a Forwarder* record"
- (Just fwp, Nothing, Nothing, Nothing, Nothing) ->
- FwderPerson fwp
- (Nothing, Just fwg, Nothing, Nothing, Nothing) ->
- FwderGroup fwg
- (Nothing, Nothing, Just fwr, Nothing, Nothing) ->
- FwderRepo fwr
- (Nothing, Nothing, Nothing, Just fwd, Nothing) ->
- FwderDeck fwd
- (Nothing, Nothing, Nothing, Nothing, Just fwl) ->
- FwderLoom fwl
- _ -> error "Found fwid with multiple forwarders"
- , sig
- )
- )
- )
- , since
- )
-
- decideBySinceFW dropAfter now (fw@(_, (_, (fwid, _, fwder, _))), msince) =
- case msince of
- Nothing -> Right fw
- Just since ->
- if relevant dropAfter now since
- then Right fw
- else Left (fwid, bmap entityKey fwder)
-
- groupUnlinked
- = map (second $ groupWithExtractBy1 ((==) `on` fst) fst snd)
- . groupWithExtractBy ((==) `on` fst) fst snd
-
- groupLinked
- = map (second $ groupWithExtractBy1 ((==) `on` fst) fst snd)
- . groupWithExtractBy ((==) `on` fst) fst snd
-
- groupForwarding
- = map (second $ groupWithExtractBy1 ((==) `on` fst) fst snd)
- . groupWithExtractBy ((==) `on` fst) fst snd
-
- fork action = do
- wait <- asyncWorker action
- return $ do
- result <- wait
- case result of
- Left e -> do
- logError $ "Periodic delivery error! " <> T.pack (displayException e)
- return False
- Right success -> return success
-
- deliverLinked deliver now ((_, h), recips) = do
- logDebug $ "Periodic deliver starting linked for host " <> renderAuthority h
- waitsR <- for recips $ \ ((raid, (ident, inbox)), delivs) -> fork $ do
- logDebug $
- "Periodic deliver starting linked for actor " <>
- renderObjURI (ObjURI h ident)
- waitsD <- for delivs $ \ (dlid, fwd, doc) -> fork $ do
- let fwd' = if fwd then Just ident else Nothing
- e <- deliver doc fwd' h inbox
- case e of
- Left err -> do
- logError $ T.concat
- [ "Periodic DL delivery #", T.pack $ show dlid
- , " error for <", renderObjURI $ ObjURI h ident, ">: "
- , T.pack $ displayException err
- ]
- return False
- Right _resp -> do
- runSiteDB $ delete dlid
- return True
- results <- sequence waitsD
- runSiteDB $
- if and results
- then update raid [RemoteActorErrorSince =. Nothing]
- else if or results
- then update raid [RemoteActorErrorSince =. Just now]
- else updateWhere [RemoteActorId ==. raid, RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now]
- return True
- results <- sequence waitsR
- unless (and results) $
- logError $ "Periodic DL delivery error for host " <> renderAuthority h
- return True
-
- deliverUnlinked deliver now ((iid, h), recips) = do
- logDebug $ "Periodic deliver starting unlinked for host " <> renderAuthority h
- waitsR <- for recips $ \ ((uraid, luRecip), delivs) -> fork $ do
- logDebug $
- "Periodic deliver starting unlinked for actor " <>
- renderObjURI (ObjURI h luRecip)
- e <- fetchRemoteActor iid h luRecip
- case e of
- Right (Right mera) ->
- case mera of
- Nothing -> runSiteDB $ deleteWhere [UnlinkedDeliveryId <-. map fst4 (NE.toList delivs)]
- Just (Entity raid ra) -> do
- waitsD <- for delivs $ \ (udlid, fwd, obid, doc) -> fork $ do
- let fwd' = if fwd then Just luRecip else Nothing
- e' <- deliver doc fwd' h $ remoteActorInbox ra
- case e' of
- Left _err -> do
- runSiteDB $ do
- delete udlid
- insert_ $ Delivery raid obid fwd False
- return False
- Right _resp -> do
- runSiteDB $ delete udlid
- return True
- results <- sequence waitsD
- runSiteDB $
- if and results
- then update raid [RemoteActorErrorSince =. Nothing]
- else if or results
- then update raid [RemoteActorErrorSince =. Just now]
- else updateWhere [RemoteActorId ==. raid, RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now]
- _ -> runSiteDB $ updateWhere [UnfetchedRemoteActorId ==. uraid, UnfetchedRemoteActorSince ==. Nothing] [UnfetchedRemoteActorSince =. Just now]
- return True
- results <- sequence waitsR
- unless (and results) $
- logError $ "Periodic UDL delivery error for host " <> renderAuthority h
- return True
-
- deliverForwarding now ((_, h), recips) = do
- logDebug $ "Periodic deliver starting forwarding for host " <> renderAuthority h
- waitsR <- for recips $ \ ((raid, inbox), delivs) -> fork $ do
- logDebug $
- "Periodic deliver starting forwarding for inbox " <>
- renderObjURI (ObjURI h inbox)
- waitsD <- for delivs $ \ (fwid, body, fwderE, sig) -> fork $ do
- let (fwderK, senderK) = splitForwarder fwderE
- sender <- renderLocalActor <$> hashLocalActor senderK
- e <- forwardActivity (ObjURI h inbox) sig sender body
- case e of
- Left _err -> return False
- Right _resp -> do
- runSiteDB $ do
- case fwderK of
- FwderPerson k -> delete k
- FwderGroup k -> delete k
- FwderRepo k -> delete k
- FwderDeck k -> delete k
- FwderLoom k -> delete k
- delete fwid
- return True
- results <- sequence waitsD
- runSiteDB $
- if and results
- then update raid [RemoteActorErrorSince =. Nothing]
- else if or results
- then update raid [RemoteActorErrorSince =. Just now]
- else updateWhere [RemoteActorId ==. raid, RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now]
- return True
- results <- sequence waitsR
- unless (and results) $
- logError $ "Periodic FW delivery error for host " <> renderAuthority h
- return True
- where
- splitForwarder (FwderPerson (Entity f (ForwarderPerson _ p))) =
- (FwderPerson f, LocalActorPerson p)
- splitForwarder (FwderGroup (Entity f (ForwarderGroup _ g))) =
- (FwderGroup f, LocalActorGroup g)
- splitForwarder (FwderRepo (Entity f (ForwarderRepo _ r))) =
- (FwderRepo f, LocalActorRepo r)
- splitForwarder (FwderDeck (Entity f (ForwarderDeck _ d))) =
- (FwderDeck f, LocalActorDeck d)
- splitForwarder (FwderLoom (Entity f (ForwarderLoom _ l))) =
- (FwderLoom f, LocalActorLoom l)
diff --git a/src/Vervis/Handler/Cloth.hs b/src/Vervis/Handler/Cloth.hs
index 15e5a16..6e357f5 100644
--- a/src/Vervis/Handler/Cloth.hs
+++ b/src/Vervis/Handler/Cloth.hs
@@ -86,7 +86,6 @@ import Database.Persist.Local
import Yesod.Persist.Local
import Vervis.ActivityPub
-import Vervis.Actor
import Vervis.API
import Vervis.Cloth
import Vervis.Data.Actor
@@ -100,6 +99,7 @@ import Vervis.Paginate
import Vervis.Persist.Actor
import Vervis.Recipient
import Vervis.Ticket
+import Vervis.Web.Actor
getClothR :: KeyHashid Loom -> KeyHashid TicketLoom -> Handler TypedContent
getClothR loomHash clothHash = do
diff --git a/src/Vervis/Handler/Deck.hs b/src/Vervis/Handler/Deck.hs
index ac4721e..cabb8d6 100644
--- a/src/Vervis/Handler/Deck.hs
+++ b/src/Vervis/Handler/Deck.hs
@@ -56,6 +56,7 @@ where
import Control.Monad
import Control.Monad.Trans.Except
import Data.Aeson
+import Data.ByteString (ByteString)
import Data.Foldable
import Data.Maybe (fromMaybe)
import Data.Text (Text)
@@ -90,14 +91,16 @@ import Data.Paginate.Local
import Database.Persist.Local
import Yesod.Persist.Local
-import Vervis.Actor
import Vervis.API
-import Vervis.Federation
+import Vervis.Federation.Auth
+import Vervis.FedURI
import Vervis.Form.Project
import Vervis.Foundation
import Vervis.Model
import Vervis.Paginate
+import Vervis.Recipient
import Vervis.Settings
+import Vervis.Web.Actor
import Vervis.Widget.Person
import qualified Vervis.Client as C
@@ -147,8 +150,41 @@ getDeckR deckHash = do
getDeckInboxR :: KeyHashid Deck -> Handler TypedContent
getDeckInboxR = getInbox DeckInboxR deckActor
-postDeckInboxR :: KeyHashid Deck -> Handler TypedContent
-postDeckInboxR _ = error "Temporarily disabled"
+postDeckInboxR :: KeyHashid Deck -> Handler ()
+postDeckInboxR recipDeckHash =
+ postInbox $ handleRobotInbox (LocalActorDeck recipDeckHash) handle
+ where
+ handle
+ :: RemoteAuthor
+ -> Maybe (RecipientRoutes, ByteString)
+ -> LocalURI
+ -> SpecificActivity URIMode
+ -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
+ handle _author _mfwd _luActivity specific =
+ case specific of
+ {-
+ CreateActivity (Create obj mtarget) ->
+ case obj of
+ CreateNote _ note ->
+ (,Nothing) <$> projectCreateNoteF now shrRecip prjRecip remoteAuthor body mfwd luActivity note
+ CreateTicket _ ticket ->
+ (,Nothing) <$> projectCreateTicketF now shrRecip prjRecip remoteAuthor body mfwd luActivity ticket mtarget
+ _ -> error "Unsupported create object type for projects"
+ FollowActivity follow ->
+ (,Nothing) <$> projectFollowF shrRecip prjRecip now remoteAuthor body mfwd luActivity follow
+ OfferActivity (Offer obj target) ->
+ case obj of
+ OfferTicket ticket ->
+ (,Nothing) <$> projectOfferTicketF now shrRecip prjRecip remoteAuthor body mfwd luActivity ticket target
+ OfferDep dep ->
+ projectOfferDepF now shrRecip prjRecip remoteAuthor body mfwd luActivity dep target
+ _ -> return ("Unsupported offer object type for projects", Nothing)
+ ResolveActivity resolve ->
+ (,Nothing) <$> projectResolveF now shrRecip prjRecip remoteAuthor body mfwd luActivity resolve
+ UndoActivity undo ->
+ (,Nothing) <$> projectUndoF shrRecip prjRecip now remoteAuthor body mfwd luActivity undo
+ -}
+ _ -> return ("Unsupported activity type for decks", Nothing)
getDeckOutboxR :: KeyHashid Deck -> Handler TypedContent
getDeckOutboxR = getOutbox DeckOutboxR deckActor
diff --git a/src/Vervis/Handler/Discussion.hs b/src/Vervis/Handler/Discussion.hs
index 7f53c39..71d176b 100644
--- a/src/Vervis/Handler/Discussion.hs
+++ b/src/Vervis/Handler/Discussion.hs
@@ -1,6 +1,6 @@
{- This file is part of Vervis.
-
- - Written in 2016, 2019, 2020 by fr33domlover .
+ - Written in 2016, 2019, 2020, 2022 by fr33domlover .
-
- ♡ Copying is an act of love. Please copy, reuse and share.
-
@@ -57,7 +57,6 @@ import Yesod.Persist.Local
import Vervis.API
import Vervis.Discussion
-import Vervis.Federation
import Vervis.FedURI
import Vervis.Form.Discussion
import Vervis.Foundation
diff --git a/src/Vervis/Handler/Group.hs b/src/Vervis/Handler/Group.hs
index abfd07d..71dd001 100644
--- a/src/Vervis/Handler/Group.hs
+++ b/src/Vervis/Handler/Group.hs
@@ -65,12 +65,12 @@ import Yesod.Hashids
import qualified Web.ActivityPub as AP
-import Vervis.Actor
import Vervis.Foundation
import Vervis.Model
import Vervis.Model.Group
import Vervis.Settings (widgetFile)
import Vervis.Time (showDate)
+import Vervis.Web.Actor
getGroupR :: KeyHashid Group -> Handler TypedContent
getGroupR groupHash = do
diff --git a/src/Vervis/Handler/Inbox.hs b/src/Vervis/Handler/Inbox.hs
index eab3496..19ea3bd 100644
--- a/src/Vervis/Handler/Inbox.hs
+++ b/src/Vervis/Handler/Inbox.hs
@@ -96,7 +96,6 @@ import Vervis.ActivityPub
import Vervis.ActorKey
import Vervis.API
import Vervis.FedURI
-import Vervis.Federation
import Vervis.Federation.Auth
import Vervis.Foundation
import Vervis.Model hiding (Ticket)
diff --git a/src/Vervis/Handler/Loom.hs b/src/Vervis/Handler/Loom.hs
index d1d4b50..06ddb1f 100644
--- a/src/Vervis/Handler/Loom.hs
+++ b/src/Vervis/Handler/Loom.hs
@@ -27,6 +27,7 @@ where
import Control.Monad
import Control.Monad.Trans.Except
import Data.Aeson
+import Data.ByteString (ByteString)
import Data.Foldable
import Data.Maybe (fromMaybe)
import Data.Text (Text)
@@ -60,13 +61,15 @@ import Data.Paginate.Local
import Database.Persist.Local
import Yesod.Persist.Local
-import Vervis.Actor
import Vervis.API
-import Vervis.Federation
+import Vervis.Federation.Auth
+import Vervis.FedURI
import Vervis.Foundation
import Vervis.Model
import Vervis.Paginate
+import Vervis.Recipient
import Vervis.Settings
+import Vervis.Web.Actor
getLoomR :: KeyHashid Loom -> Handler TypedContent
getLoomR loomHash = do
@@ -105,8 +108,19 @@ getLoomR loomHash = do
getLoomInboxR :: KeyHashid Loom -> Handler TypedContent
getLoomInboxR = getInbox LoomInboxR loomActor
-postLoomInboxR :: KeyHashid Loom -> Handler TypedContent
-postLoomInboxR _ = error "Temporarily disabled"
+postLoomInboxR :: KeyHashid Loom -> Handler ()
+postLoomInboxR recipLoomHash =
+ postInbox $ handleRobotInbox (LocalActorLoom recipLoomHash) handle
+ where
+ handle
+ :: RemoteAuthor
+ -> Maybe (RecipientRoutes, ByteString)
+ -> LocalURI
+ -> AP.SpecificActivity URIMode
+ -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
+ handle _author _mfwd _luActivity specific =
+ case specific of
+ _ -> return ("Unsupported activity type for looms", Nothing)
getLoomOutboxR :: KeyHashid Loom -> Handler TypedContent
getLoomOutboxR = getOutbox LoomOutboxR loomActor
diff --git a/src/Vervis/Handler/Person.hs b/src/Vervis/Handler/Person.hs
index d251226..3cf497a 100644
--- a/src/Vervis/Handler/Person.hs
+++ b/src/Vervis/Handler/Person.hs
@@ -65,7 +65,6 @@ import Data.Either.Local
import Database.Persist.Local
import Vervis.ActivityPub
-import Vervis.Actor
import Vervis.ActorKey
import Vervis.API
import Vervis.Data.Actor
@@ -78,6 +77,7 @@ import Vervis.Recipient
import Vervis.Secure
import Vervis.Settings
import Vervis.Ticket
+import Vervis.Web.Actor
import Vervis.Widget
import Vervis.Widget.Person
diff --git a/src/Vervis/Handler/Repo.hs b/src/Vervis/Handler/Repo.hs
index 4c25245..962cc4e 100644
--- a/src/Vervis/Handler/Repo.hs
+++ b/src/Vervis/Handler/Repo.hs
@@ -72,6 +72,7 @@ import Control.Monad.Logger (logWarn)
import Control.Monad.Trans.Except
import Data.Bifunctor
import Data.Binary.Put
+import Data.ByteString (ByteString)
import Data.Foldable
import Data.Git.Graph
import Data.Git.Harder
@@ -147,17 +148,20 @@ import Yesod.Persist.Local
import qualified Data.Git.Local as G (createRepo)
import qualified Darcs.Local.Repository as D (createRepo)
-import Vervis.Actor
import Vervis.API
+import Vervis.Federation.Auth
+import Vervis.FedURI
import Vervis.Foundation
import Vervis.Path
import Vervis.Model
import Vervis.Model.Ident
import Vervis.Paginate
import Vervis.Readme
+import Vervis.Recipient
import Vervis.Settings
import Vervis.SourceTree
import Vervis.Style
+import Vervis.Web.Actor
import qualified Vervis.Formatting as F
import qualified Vervis.Hook as H
@@ -206,8 +210,48 @@ getRepoR repoHash = do
getRepoInboxR :: KeyHashid Repo -> Handler TypedContent
getRepoInboxR = getInbox RepoInboxR repoActor
-postRepoInboxR :: KeyHashid Repo -> Handler TypedContent
-postRepoInboxR _ = error "Temporarily disabled"
+postRepoInboxR :: KeyHashid Repo -> Handler ()
+postRepoInboxR recipRepoHash =
+ postInbox $ handleRobotInbox (LocalActorRepo recipRepoHash) handle
+ where
+ handle
+ :: RemoteAuthor
+ -> Maybe (RecipientRoutes, ByteString)
+ -> LocalURI
+ -> AP.SpecificActivity URIMode
+ -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
+ handle _author _mfwd _luActivity specific =
+ case specific of
+ {-
+ ApplyActivity (AP.Apply uObject uTarget) ->
+ repoApplyF now shrRecip rpRecip remoteAuthor body mfwd luActivity uObject uTarget
+ AddActivity (AP.Add obj target) ->
+ case obj of
+ Right (AddBundle patches) ->
+ repoAddBundleF now shrRecip rpRecip remoteAuthor body mfwd luActivity patches target
+ _ -> return ("Unsupported add object type for repos", Nothing)
+ CreateActivity (Create obj mtarget) ->
+ case obj of
+ CreateNote _ note ->
+ (,Nothing) <$> repoCreateNoteF now shrRecip rpRecip remoteAuthor body mfwd luActivity note
+ CreateTicket _ ticket ->
+ (,Nothing) <$> repoCreateTicketF now shrRecip rpRecip remoteAuthor body mfwd luActivity ticket mtarget
+ _ -> error "Unsupported create object type for repos"
+ FollowActivity follow ->
+ (,Nothing) <$> repoFollowF shrRecip rpRecip now remoteAuthor body mfwd luActivity follow
+ OfferActivity (Offer obj target) ->
+ case obj of
+ OfferTicket ticket ->
+ (,Nothing) <$> repoOfferTicketF now shrRecip rpRecip remoteAuthor body mfwd luActivity ticket target
+ OfferDep dep ->
+ repoOfferDepF now shrRecip rpRecip remoteAuthor body mfwd luActivity dep target
+ _ -> return ("Unsupported offer object type for repos", Nothing)
+ ResolveActivity resolve ->
+ (,Nothing) <$> repoResolveF now shrRecip rpRecip remoteAuthor body mfwd luActivity resolve
+ UndoActivity undo->
+ (,Nothing) <$> repoUndoF shrRecip rpRecip now remoteAuthor body mfwd luActivity undo
+ -}
+ _ -> return ("Unsupported activity type for repos", Nothing)
getRepoOutboxR :: KeyHashid Repo -> Handler TypedContent
getRepoOutboxR = getOutbox RepoOutboxR repoActor
diff --git a/src/Vervis/Handler/Ticket.hs b/src/Vervis/Handler/Ticket.hs
index bb58212..7161fff 100644
--- a/src/Vervis/Handler/Ticket.hs
+++ b/src/Vervis/Handler/Ticket.hs
@@ -131,11 +131,9 @@ import Database.Persist.Local
import Yesod.Persist.Local
import Vervis.ActivityPub
-import Vervis.Actor
import Vervis.API
import Vervis.Data.Actor
import Vervis.Discussion
-import Vervis.Federation
import Vervis.FedURI
import Vervis.Foundation
import Vervis.Handler.Discussion
@@ -152,6 +150,7 @@ import Vervis.Style
import Vervis.Ticket
import Vervis.TicketFilter (filterTickets)
import Vervis.Time (showDate)
+import Vervis.Web.Actor
getTicketR :: KeyHashid Deck -> KeyHashid TicketDeck -> Handler TypedContent
getTicketR deckHash ticketHash = do
diff --git a/src/Vervis/Actor.hs b/src/Vervis/Web/Actor.hs
similarity index 94%
rename from src/Vervis/Actor.hs
rename to src/Vervis/Web/Actor.hs
index 28413c7..119ff62 100644
--- a/src/Vervis/Actor.hs
+++ b/src/Vervis/Web/Actor.hs
@@ -13,7 +13,7 @@
- .
-}
-module Vervis.Actor
+module Vervis.Web.Actor
( getInbox
, postInbox
, getOutbox
@@ -21,6 +21,7 @@ module Vervis.Actor
, getFollowersCollection
, getActorFollowersCollection
, getFollowingCollection
+ , handleRobotInbox
)
where
@@ -37,6 +38,7 @@ import Data.Aeson
import Data.Aeson.Encode.Pretty
import Data.Bifunctor
import Data.Bitraversable
+import Data.ByteString (ByteString)
import Data.Foldable (for_)
import Data.List
import Data.Maybe
@@ -77,6 +79,7 @@ import Yesod.Hashids
import Yesod.MonadSite
import Yesod.RenderSource
+import Control.Monad.Trans.Except.Local
import Data.Aeson.Local
import Data.Either.Local
import Data.EventTime.Local
@@ -89,7 +92,6 @@ import Vervis.ActivityPub
import Vervis.ActorKey
import Vervis.API
import Vervis.FedURI
-import Vervis.Federation
import Vervis.Federation.Auth
import Vervis.Foundation
import Vervis.Model hiding (Ticket)
@@ -453,3 +455,29 @@ getFollowingCollection here actor hash = do
getRemotes aid =
map (followRemoteTarget . entityVal) <$>
selectList [FollowRemoteActor ==. aid] []
+
+handleRobotInbox
+ :: LocalActorBy KeyHashid
+ -> ( RemoteAuthor
+ -> Maybe (RecipientRoutes, ByteString)
+ -> LocalURI
+ -> SpecificActivity URIMode
+ -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
+ )
+ -> UTCTime
+ -> ActivityAuthentication
+ -> ActivityBody
+ -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
+handleRobotInbox recipByHash handleSpecific now auth body = do
+ remoteAuthor <-
+ case auth of
+ ActivityAuthLocal _ -> throwE "Got a forwarded local activity, I don't need those"
+ ActivityAuthRemote ra -> return ra
+ luActivity <-
+ fromMaybeE (activityId $ actbActivity body) "Activity without 'id'"
+ localRecips <- do
+ mrecips <- parseAudience $ activityAudience $ actbActivity body
+ paudLocalRecips <$> fromMaybeE mrecips "Activity with no recipients"
+ msig <- checkForwarding recipByHash
+ let mfwd = (localRecips,) <$> msig
+ handleSpecific remoteAuthor mfwd luActivity (activitySpecific $ actbActivity body)
diff --git a/vervis.cabal b/vervis.cabal
index e7b4e72..9757ff7 100644
--- a/vervis.cabal
+++ b/vervis.cabal
@@ -124,7 +124,6 @@ library
Vervis.Access
Vervis.ActivityPub
- Vervis.Actor
Vervis.ActorKey
Vervis.API
Vervis.Avatar
@@ -143,7 +142,7 @@ library
Vervis.Delivery
Vervis.Discussion
- Vervis.Federation
+ --Vervis.Federation
Vervis.Federation.Auth
--Vervis.Federation.Discussion
--Vervis.Federation.Offer
@@ -224,6 +223,9 @@ library
Vervis.Ticket
Vervis.TicketFilter
Vervis.Time
+
+ Vervis.Web.Actor
+
Vervis.Widget
Vervis.Widget.Discussion
Vervis.Widget.Person