Implement outbox remote delivery, in handler and periodic, not used yet

config/models

@@ -54,6 +54,20 @@ InboxItemLocal
 
     UniqueInboxItemLocal person activity
 
+UnlinkedDelivery
+    recipient UnfetchedRemoteActorId
+    activity  OutboxItemId
+    running   Bool
+
+    UniqueUnlinkedDelivery recipient activity
+
+Delivery
+    recipient RemoteActorId
+    activity  OutboxItemId
+    running   Bool
+
+    UniqueDelivery recipient activity
+
 VerifKey
     ident    LocalURI
     instance InstanceId
@@ -69,6 +83,13 @@ VerifKeySharedUsage
 
     UniqueVerifKeySharedUsage key user
 
+UnfetchedRemoteActor
+    instance InstanceId
+    ident    LocalURI
+    since    UTCTime Maybe
+
+    UniqueUnfetchedRemoteActor instance ident
+
 RemoteActor
     ident      LocalURI
     instance   InstanceId

migrations/2019_04_12.model

@@ -0,0 +1,20 @@
+UnfetchedRemoteActor
+    instance InstanceId
+    ident    Text
+    since    UTCTime Maybe
+
+    UniqueUnfetchedRemoteActor instance ident
+
+UnlinkedDelivery
+    recipient UnfetchedRemoteActorId
+    activity  OutboxItemId
+    running   Bool
+
+    UniqueUnlinkedDelivery recipient activity
+
+Delivery
+    recipient RemoteActorId
+    activity  OutboxItemId
+    running   Bool
+
+    UniqueDelivery recipient activity

src/Control/Concurrent/ResultShare.hs

@@ -63,7 +63,7 @@ data ResultShare m k v a = ResultShare
     }
 
 newResultShare
-    :: MonadIO m => ResultShareSettings m k v a -> m (ResultShare m k v a)
+    :: MonadIO n => ResultShareSettings m k v a -> n (ResultShare m k v a)
 newResultShare (ResultShareSettings fork action) = do
     tvar <- liftIO $ newTVarIO M.empty
     return $ ResultShare tvar fork action

src/Vervis/Application.hs

@@ -60,12 +60,15 @@ import Control.Concurrent.Local (forkCheck)
 
 import Database.Persist.Schema.PostgreSQL (schemaBackend)
 
+import Control.Concurrent.ResultShare
 import Data.KeyFile
+
 import Web.Hashids.Local
 
 import Vervis.ActorKey (generateActorKey, actorKeyRotator)
+import Vervis.Federation
 import Vervis.KeyFile (isInitialSetup)
-import Vervis.RemoteActorStore (newInstanceMutex)
+import Vervis.RemoteActorStore
 
 -- Import all relevant handler modules here.
 -- Don't forget to add new modules to your cabal file!
@@ -125,6 +128,8 @@ makeFoundation appSettings = do
 
     appInstanceMutex <- newInstanceMutex
 
+    appActorFetchShare <- newResultShare actorFetchShareSettings
+
     appActivities <- newTVarIO mempty
 
     -- We need a log function to create a connection pool. We need a connection
@@ -169,7 +174,10 @@ makeFoundation appSettings = do
                     let msg = "DB migration failed: " <> err
                     $logError msg
                     error $ T.unpack msg
-                Right (_from, _to) -> $logInfo "DB migration success"
+                Right (_from, _to) -> do
+                    $logInfo "DB migration success"
+                    fixRunningDeliveries
+                    deleteUnusedURAs
 
     -- Return the foundation
     return $ mkFoundation pool capSignKey hashidsCtx

src/Vervis/Federation.hs

@@ -15,18 +15,23 @@
 
 module Vervis.Federation
     ( handleInboxActivity
+    , fixRunningDeliveries
     , handleOutboxNote
+    , retryOutboxDelivery
     )
 where
 
 import Prelude
 
+import Control.Applicative
+import Control.Concurrent.MVar
 import Control.Concurrent.STM.TVar
 import Control.Exception hiding (Handler, try)
 import Control.Monad
 import Control.Monad.Logger.CallStack
 import Control.Monad.Trans.Except
 import Control.Monad.Trans.Maybe
+import Control.Monad.Trans.Reader
 import Data.Aeson (Object)
 import Data.Bifunctor
 import Data.Either
@@ -43,8 +48,10 @@ import Data.Traversable
 import Data.Tuple
 import Database.Persist hiding (deleteBy)
 import Database.Persist.Sql hiding (deleteBy)
+import Network.HTTP.Client
 import Network.HTTP.Types.Header
 import Network.HTTP.Types.URI
+import Network.TLS
 import UnliftIO.Exception (try)
 import Yesod.Core hiding (logError, logWarn, logInfo)
 import Yesod.Persist.Core
@@ -66,6 +73,7 @@ import Yesod.Hashids
 import Data.Either.Local
 import Data.List.Local
 import Data.List.NonEmpty.Local
+import Data.Maybe.Local
 import Database.Persist.Local
 
 import Vervis.ActorKey
@@ -296,329 +304,20 @@ handleInboxActivity raw hActor iidActor rsidActor (Activity _id _luActor audienc
                     ]
             return (uNote, luContext)
 
-{-
+fixRunningDeliveries :: (MonadIO m, MonadLogger m, IsSqlBackend backend) => ReaderT backend m ()
--- | Handle a Note submitted by a local user to their outbox. It can be either
+fixRunningDeliveries = do
--- a comment on a local ticket, or a comment on some remote context. Return an
+    c <- updateWhereCount [UnlinkedDeliveryRunning ==. True] [UnlinkedDeliveryRunning =. False]
--- error message if the Note is rejected, otherwise the new 'LocalMessageId'.
+    unless (c == 0) $ logWarn $ T.concat
-handleOutboxNote :: Text -> Note -> Handler (Either Text LocalMessageId)
+        [ "fixRunningDeliveries fixed "
-handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished content) = runExceptT $ do
+        , T.pack (show c)
-    verifyHostLocal host "Attributed to non-local actor"
+        , " linked deliveries"
-    verifyNothing mluNote "Note specifies an id"
+        ]
-    verifyNothing mpublished "Note specifies published"
+    c' <- updateWhereCount [DeliveryRunning ==. True] [DeliveryRunning =. False]
-    uContext <- fromMaybeE muContext "Note without context"
+    unless (c' == 0) $ logWarn $ T.concat
-    uRecip <- parseAudience aud "Note has not-just-single-to audience"
+        [ "fixRunningDeliveries fixed "
-    recipContextParent <- parseRecipContextParent uRecip uContext muParent
+        , T.pack (show c)
-
+        , " unlinked deliveries"
-    (lmid, mdeliver) <- ExceptT $ runDB $ runExceptT $ do
+        ]
-        (pid, shrUser) <- verifyIsLoggedInUser luAttrib "Note attributed to different actor"
-        case recipContextParent of
-            (mparent, Left (shr, prj, num)) -> do
-                mdid <- lift $ runMaybeT $ do
-                    sid <- MaybeT $ getKeyBy $ UniqueSharer shr
-                    jid <- MaybeT $ getKeyBy $ UniqueProject prj sid
-                    t <- MaybeT $ getValBy $ UniqueTicket jid num
-                    return $ ticketDiscuss t
-                did <- fromMaybeE mdid "Context: No such local ticket"
-                mmidParent <- for mparent $ \ parent ->
-                    case parent of
-                        Left (shrParent, lmidParent) -> getLocalParentMessageId did shrParent lmidParent
-                        Right (hParent, luParent) -> do
-                            mrm <- lift $ runMaybeT $ do
-                                iid <- MaybeT $ getKeyBy $ UniqueInstance hParent
-                                MaybeT $ getValBy $ UniqueRemoteMessageIdent iid luParent
-                            rm <- fromMaybeE mrm "Remote parent unknown locally"
-                            let mid = remoteMessageRest rm
-                            m <- lift $ getJust mid
-                            unless (messageRoot m == did) $
-                                throwE "Remote parent belongs to a different discussion"
-                            return mid
-                let meparent = Left <$> mmidParent
-                (lmid, _doc) <- lift $ insertMessage luAttrib shrUser pid uContext did muParent meparent content
-                return (lmid, Nothing)
-            (mparent, Right (hRecip, luRecip, luContext)) -> do
-                (did, rdid, rdnew, mluInbox) <- do
-                    miid <- lift $ getKeyBy $ UniqueInstance hRecip
-                    erd <-
-                        case miid of
-                            Just iid -> findExistingRemoteDiscussion iid hRecip luRecip luContext
-                            Nothing -> return Nothing
-                    case erd of
-                        Just (d, rd, minb) -> return (d, rd, False, minb)
-                        Nothing -> ExceptT $ withHostLock hRecip $ runExceptT $ storeRemoteDiscussion miid hRecip luRecip luContext
-                meparent <- for mparent $ \ parent ->
-                    case parent of
-                        Left (shrParent, lmidParent) -> do
-                            when rdnew $ throwE "Local parent inexistent, RemoteDiscussion is new"
-                            Left <$> getLocalParentMessageId did shrParent lmidParent
-                        Right (hParent, luParent) -> do
-                            mrm <- lift $ runMaybeT $ do
-                                iid <- MaybeT $ getKeyBy $ UniqueInstance hParent
-                                MaybeT $ getValBy $ UniqueRemoteMessageIdent iid luParent
-                            case mrm of
-                                Nothing -> return $ Right $ l2f hParent luParent
-                                Just rm -> Left <$> do
-                                    let mid = remoteMessageRest rm
-                                    m <- lift $ getJust mid
-                                    unless (messageRoot m == did) $
-                                        throwE "Remote parent belongs to a different discussion"
-                                    return mid
-                (lmid, doc) <- lift $ insertMessage luAttrib shrUser pid uContext did muParent meparent content
-                return (lmid, Just (doc, hRecip, maybe (Right (luRecip, rdid)) Left mluInbox))
-    let handleDeliverError e = logError $ "Outbox POST handler: delivery failed! " <> T.pack (displayException e)
-    lift $ for_ mdeliver $ \ (doc, hRecip, einb) -> forkHandler handleDeliverError $ do
-        uInbox <-
-            case einb of
-                Left luInbox -> return $ l2f hRecip luInbox
-                Right (luRecip, rdid) -> do
-                    mluInbox <- runDB $ runMaybeT $ do
-                        iid <- MaybeT $ getKeyBy $ UniqueInstance hRecip
-                        rs <- MaybeT $ getValBy $ UniqueRemoteActor iid luRecip
-                        return $ remoteActorInbox rs
-                    case mluInbox of
-                        Just luInbox -> return $ l2f hRecip luInbox
-                        Nothing -> do
-                            manager <- getsYesod appHttpManager
-                            eactor <- fetchAPID manager actorId hRecip luRecip
-                            case eactor of
-                                Left s -> fail $ "Fetched recipient actor: " ++ s
-                                Right actor -> withHostLock hRecip $ runDB $ do
-                                    iid <- either entityKey id <$> insertBy (Instance hRecip)
-                                    let luInbox = actorInbox actor
-                                    rsid <- either entityKey id <$> insertBy (RemoteActor luRecip iid luInbox Nothing)
-                                    update rdid [RemoteDiscussionActor =. Just rsid, RemoteDiscussionUnlinkedActor =. Nothing]
-                                    return $ l2f hRecip luInbox
-        -- TODO based on the httpPostAP usage in postOutboxR
-        manager <- getsYesod appHttpManager
-        (akey1, akey2, new1) <- liftIO . readTVarIO =<< getsYesod appActorKeys
-        renderUrl <- getUrlRender
-        let (keyID, akey) =
-                if new1
-                    then (renderUrl ActorKey1R, akey1)
-                    else (renderUrl ActorKey2R, akey2)
-            sign b = (KeyId $ encodeUtf8 keyID, actorKeySign akey b)
-            actorID = renderFedURI $ l2f host luAttrib
-        eres <- httpPostAP manager uInbox (hRequestTarget :| [hHost, hDate, hActivityPubActor]) sign actorID doc
-        case eres of
-            Left e -> logError $ "Failed to POST to recipient's inbox: " <> T.pack (displayException e)
-            Right _ -> logInfo $ T.concat
-                [ "Successful delivery of <"
-                , renderFedURI $ l2f (docHost doc) (activityId $ docValue doc)
-                , " to <"
-                , renderFedURI uRecip
-                , ">"
-                ]
-    return lmid
-    where
-    verifyNothing :: Monad m => Maybe a -> Text -> ExceptT Text m ()
-    verifyNothing Nothing  _ = return ()
-    verifyNothing (Just _) t = throwE t
-
-    verifySameHost
-        :: Monad m => Text -> FedURI -> Text -> ExceptT Text m LocalURI
-    verifySameHost h fu t = do
-        let (h', lu) = f2l fu
-        if h == h'
-            then return lu
-            else throwE t
-
-    parseRecipContextParent
-        :: FedURI
-        -> FedURI
-        -> Maybe FedURI
-        -> ExceptT
-            Text
-            Handler
-            ( Maybe (Either (ShrIdent, LocalMessageId) (Text, LocalURI))
-            , Either
-                (ShrIdent, PrjIdent, Int)
-                (Text, LocalURI, LocalURI)
-            )
-    parseRecipContextParent uRecip uContext muParent = do
-        let r@(hRecip, luRecip) = f2l uRecip
-        luContext <- verifySameHost hRecip uContext "Recipient and context on different hosts"
-        meparent <-
-            case muParent of
-                Nothing -> return Nothing
-                Just uParent ->
-                    if uParent == uContext
-                        then return Nothing
-                        else Just <$> do
-                            let (hParent, luParent) = f2l uParent
-                            parentLocal <- hostIsLocal hParent
-                            if parentLocal
-                                then Left <$> parseComment luParent
-                                else return $ Right (hParent, luParent)
-        local <- hostIsLocal hRecip
-        if local
-            then do
-                (shr, prj) <- parseProject luRecip
-                num <- parseTicket (shr, prj) luContext
-                return (meparent, Left (shr, prj, num))
-            else do
-                when (luRecip == luContext) $
-                    throwE "Identical recipient and context"
-                {-
-                mrs <- lift $ runDB $ runMaybeT $ do
-                    iid <- MaybeT $ getKeyBy $ UniqueInstance hRecip
-                    MaybeT $ getBy $ UniqueRemoteActor iid luRecip
-                erecip <-
-                    case mrs of
-                        Just ers -> return $ Left ers
-                        Nothing -> do
-                            manager <- getsYesod appHttpManager
-                            eactor <- fetchAPID manager actorId hRecip luRecip
-                            case eactor of
-                                Left s -> throwE $ "Fetched recipient actor: " <> T.pack s
-                                Right actor -> return $ Right actor
-                -}
-                return (meparent, Right (hRecip, luRecip, luContext))
-
-    verifyIsLoggedInUser
-        :: LocalURI -> Text -> ExceptT Text AppDB (PersonId, ShrIdent)
-    verifyIsLoggedInUser lu t = do
-        Entity pid p <- requireVerifiedAuth
-        s <- lift $ getJust $ personIdent p
-        route2local <- getEncodeRouteLocal
-        let shr = sharerIdent s
-        if route2local (SharerR shr) == lu
-            then return (pid, shr)
-            else throwE t
-
-    findExistingRemoteDiscussion
-        :: InstanceId
-        -> Text
-        -> LocalURI
-        -> LocalURI
-        -> ExceptT Text AppDB
-            (Maybe (DiscussionId, RemoteDiscussionId, Maybe LocalURI))
-    findExistingRemoteDiscussion iid hRecip luRecip luContext = do
-        merd <- lift $ getBy $ UniqueRemoteDiscussionIdent iid luContext
-        for merd $ \ (Entity rdid rd) -> do
-            eactor <-
-                requireEitherM
-                    (remoteDiscussionActor rd)
-                    (remoteDiscussionUnlinkedActor rd)
-                    "RemoteDiscussion actor and unlinkedActor both unset"
-                    "RemoteDiscussion actor and unlinkedActor both set"
-            minb <- case eactor of
-                Left rsid -> do
-                    rs <- lift $ getJust rsid
-                    unless (remoteActorInstance rs == iid && remoteActorIdent rs == luRecip) $
-                        throwE "Known remote context, but its actor doesn't match the new Note's recipient"
-                    return $ Just $ remoteActorInbox rs
-                Right uActor -> do
-                    unless (uActor == l2f hRecip luRecip) $
-                        throwE "Known remote context, but its unlinked actor doesn't match the new Note's recipient"
-                    return Nothing
-            return (remoteDiscussionDiscuss rd, rdid, minb)
-
-    insertRemoteDiscussion
-        :: InstanceId
-        -> Bool
-        -> Text
-        -> LocalURI
-        -> LocalURI
-        -> AppDB (DiscussionId, RemoteDiscussionId, Maybe LocalURI)
-    insertRemoteDiscussion iid inew hRecip luRecip luContext = do
-        mrs <-
-            if inew
-                then return Nothing
-                else getBy $ UniqueRemoteActor iid luRecip
-        did <- insert Discussion
-        rdid <- insert RemoteDiscussion
-            { remoteDiscussionActor         = entityKey <$> mrs
-            , remoteDiscussionInstance      = iid
-            , remoteDiscussionIdent         = luContext
-            , remoteDiscussionDiscuss       = did
-            , remoteDiscussionUnlinkedActor =
-                case mrs of
-                    Nothing -> Just $ l2f hRecip luRecip
-                    Just _ -> Nothing
-            }
-        return (did, rdid, remoteActorInbox . entityVal <$> mrs)
-
-    storeRemoteDiscussion
-        :: Maybe InstanceId
-        -> Text
-        -> LocalURI
-        -> LocalURI
-        -> ExceptT Text AppDB
-            (DiscussionId, RemoteDiscussionId, Bool, Maybe LocalURI)
-    storeRemoteDiscussion miid hRecip luRecip luContext = do
-        (iid, inew) <-
-            case miid of
-                Just i -> return (i, False)
-                Nothing -> lift $ idAndNew <$> insertBy (Instance hRecip)
-        if inew
-            then do
-                (did, rdid, minb) <- lift $ insertRemoteDiscussion iid True hRecip luRecip luContext
-                return (did, rdid, True, minb)
-            else do
-                erd <- findExistingRemoteDiscussion iid hRecip luRecip luContext
-                case erd of
-                    Just (did, rdid, minb) -> return (did, rdid, False, minb)
-                    Nothing -> do
-                        (did, rdid, minb) <- lift $ insertRemoteDiscussion iid False hRecip luRecip luContext
-                        return (did, rdid, True, minb)
-
-    insertMessage
-        :: LocalURI
-        -> ShrIdent
-        -> PersonId
-        -> FedURI
-        -> DiscussionId
-        -> Maybe FedURI
-        -> Maybe (Either MessageId FedURI)
-        -> Text
-        -> AppDB (LocalMessageId, Doc Activity)
-    insertMessage luAttrib shrUser pid uContext did muParent meparent content = do
-        now <- liftIO getCurrentTime
-        mid <- insert Message
-            { messageCreated = now
-            , messageContent = content
-            , messageParent  =
-                case meparent of
-                    Just (Left midParent) -> Just midParent
-                    _                     -> Nothing
-            , messageRoot    = did
-            }
-        lmid <- insert LocalMessage
-            { localMessageAuthor         = pid
-            , localMessageRest           = mid
-            , localMessageUnlinkedParent =
-                case meparent of
-                    Just (Right uParent) -> Just uParent
-                    _                    -> Nothing
-            }
-        route2local <- getEncodeRouteLocal
-        lmhid <- encodeKeyHashid lmid
-        let activity luAct = Doc host Activity
-                { activityId       = luAct
-                , activityActor    = luAttrib
-                , activityAudience = aud
-                , activitySpecific = CreateActivity Create
-                    { createObject = Note
-                        { noteId        = Just $ route2local $ MessageR shrUser lmhid
-                        , noteAttrib    = luAttrib
-                        , noteAudience  = aud
-                        , noteReplyTo   = Just $ fromMaybe uContext muParent
-                        , noteContext   = Just uContext
-                        , notePublished = Just now
-                        , noteContent   = content
-                        }
-                    }
-                }
-        obid <- insert OutboxItem
-            { outboxItemPerson    = pid
-            , outboxItemActivity  = PersistJSON $ activity $ LocalURI "" ""
-            , outboxItemPublished = now
-            }
-        obhid <- encodeKeyHashid obid
-        let luAct = route2local $ OutboxItemR shrUser obhid
-            doc = activity luAct
-        update obid [OutboxItemActivity =. PersistJSON doc]
-        return (lmid, doc)
--}
 
 data LocalTicketRecipient = LocalTicketParticipants | LocalTicketTeam
     deriving (Eq, Ord)
@@ -657,6 +356,44 @@ newtype FedError = FedError Text deriving Show
 
 instance Exception FedError
 
+getHttpSign = do
+    (akey1, akey2, new1) <- liftIO . readTVarIO =<< getsYesod appActorKeys
+    renderUrl <- getUrlRender
+    let (keyID, akey) =
+            if new1
+                then (renderUrl ActorKey1R, akey1)
+                else (renderUrl ActorKey2R, akey2)
+    return $ \ b -> (KeyId $ encodeUtf8 keyID, actorKeySign akey b)
+
+deliverHttp sign doc h luInbox = do
+    manager <- getsYesod appHttpManager
+    let inbox = l2f h luInbox
+        headers = hRequestTarget :| [hHost, hDate, hActivityPubActor]
+    httpPostAP manager inbox headers sign docActor doc
+    where
+    docActor = renderFedURI $ l2f (docHost doc) (activityActor $ docValue doc)
+
+isInstanceErrorHttp (InvalidUrlException _ _)    = False
+isInstanceErrorHttp (HttpExceptionRequest _ hec) =
+    case hec of
+        ResponseTimeout -> True
+        ConnectionTimeout -> True
+        InternalException se ->
+            case fromException se of
+                Just (HandshakeFailed _) -> True
+                _ -> False
+        _ -> False
+
+isInstanceErrorP (APPostErrorSig _)   = False
+isInstanceErrorP (APPostErrorHTTP he) = isInstanceErrorHttp he
+
+isInstanceErrorG Nothing  = False
+isInstanceErrorG (Just e) =
+    case e of
+        APGetErrorHTTP he -> isInstanceErrorHttp he
+        APGetErrorJSON _ -> False
+        APGetErrorContentType _ -> False
+
 -- | Handle a Note submitted by a local user to their outbox. It can be either
 -- a comment on a local ticket, or a comment on some remote context. Return an
 -- error message if the Note is rejected, otherwise the new 'LocalMessageId'.
@@ -742,15 +479,13 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished c
                 return (did, meparent, Nothing)
         (lmid, obid, doc) <- lift $ insertMessage luAttrib shrUser pid uContext did muParent meparent content
         moreRemotes <- deliverLocal obid localRecips mcollections
-        return (lmid, doc, moreRemotes)
+        remotesHttp <- lift $ deliverRemoteDB obid remoteRecips moreRemotes
-    (lmid, doc, moreRemotes) <- case result of
+        return (lmid, obid, doc, remotesHttp)
+    (lmid, obid, doc, remotesHttp) <- case result of
         Left (FedError t) -> throwE t
         Right r -> return r
-    -- TODO deliver *async* to remote sharers: remoteRecips and moreRemotes
+    let handleDeliveryError e = logError $ "Outbox POST handler: delivery failed! " <> T.pack (displayException e)
-    --
+    lift $ forkHandler handleDeliveryError $ deliverRemoteHttp obid doc remotesHttp
-    -- doc          :: Doc Activity
-    -- remoteRecips :: [FedURI]
-    -- moreRemotes  :: [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI))]
     return lmid
     where
     verifyNothing :: Monad m => Maybe a -> e -> ExceptT e m ()
@@ -992,6 +727,12 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished c
     mergeConcat :: (Ord a, Semigroup b) => [(a, b)] -> [(a, b)] -> [(a, b)]
     mergeConcat xs ys = map (second sconcat) $ groupWithExtract fst snd $ LO.mergeBy (compare `on` fst) xs ys
 
+    fst3 :: (a, b, c) -> a
+    fst3 (x, _, _) = x
+
+    thd3 :: (a, b, c) -> c
+    thd3 (_, _, z) = z
+
     -- Deliver to local recipients. For local users, find in DB and deliver.
     -- For local collections, expand them, deliver to local users, and return a
     -- list of remote actors found in them.
@@ -999,7 +740,7 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished c
         :: OutboxItemId
         -> [ShrIdent]
         -> Maybe (SharerId, FollowerSetId)
-        -> ExceptT Text AppDB [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI))]
+        -> ExceptT Text AppDB [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, Maybe UTCTime))]
     deliverLocal obid recips mticket = do
         recipPids <- traverse getPersonId $ nub recips
         (morePids, remotes) <-
@@ -1048,7 +789,7 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished c
                           -- instances aren't repeated. Use a custom merge
                           -- where we can unionBy or LO.unionBy whenever both
                           -- lists have the same instance.
-                        , map (second $ NE.nubBy ((==) `on` fst)) $ mergeConcat teamRemotes fsRemotes
+                        , map (second $ NE.nubBy ((==) `on` fst3)) $ mergeConcat teamRemotes fsRemotes
                         )
         lift $ for_ (union recipPids morePids) $ \ pid -> insert_ $ InboxItemLocal pid obid
         return remotes
@@ -1068,11 +809,11 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished c
             case id_ of
                 Left pid -> return pid
                 Right _gid -> throwE "Local Note addresses a local group"
-        groupRemotes :: [(InstanceId, Text, RemoteActorId, LocalURI)] -> [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI))]
+        groupRemotes :: [(InstanceId, Text, RemoteActorId, LocalURI, Maybe UTCTime)] -> [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, Maybe UTCTime))]
-        groupRemotes = groupWithExtractBy ((==) `on` fst) fst snd . map toPairs
+        groupRemotes = groupWithExtractBy ((==) `on` fst) fst snd . map toTuples
             where
-            toPairs (iid, h, rsid, lu) = ((iid, h), (rsid, lu))
+            toTuples (iid, h, rsid, lu, ms) = ((iid, h), (rsid, lu, ms))
-        getTicketTeam :: SharerId -> AppDB ([PersonId], [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI))])
+        getTicketTeam :: SharerId -> AppDB ([PersonId], [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, Maybe UTCTime))])
         getTicketTeam sid = do
             id_ <- getPersonOrGroupId sid
             (,[]) <$> case id_ of
@@ -1080,7 +821,7 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished c
                 Right gid ->
                     map (groupMemberPerson . entityVal) <$>
                         selectList [GroupMemberGroup ==. gid] []
-        getFollowers :: FollowerSetId -> AppDB ([PersonId], [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI))])
+        getFollowers :: FollowerSetId -> AppDB ([PersonId], [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, Maybe UTCTime))])
         getFollowers fsid = do
             local <- selectList [FollowTarget ==. fsid] []
             remote <- E.select $ E.from $ \ (rf `E.InnerJoin` rs `E.InnerJoin` i) -> do
@@ -1093,12 +834,13 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished c
                     , i E.^. InstanceHost
                     , rs E.^. RemoteActorId
                     , rs E.^. RemoteActorInbox
+                    , rs E.^. RemoteActorErrorSince
                     )
             return
                 ( map (followPerson . entityVal) local
                 , groupRemotes $
-                    map (\ (E.Value iid, E.Value h, E.Value rsid, E.Value luInbox) ->
+                    map (\ (E.Value iid, E.Value h, E.Value rsid, E.Value luInbox, E.Value msince) ->
-                            (iid, h, rsid, luInbox)
+                            (iid, h, rsid, luInbox, msince)
                         )
                         remote
                 )
@@ -1118,56 +860,328 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished c
             Left pid -> lift $ insert_ $ InboxItemLocal pid obid
             Right _gid -> throwE "Local Note addresses a local group"
 
-    -- TODO NEXT: So far, we have 2 groups of remote actors to handle,
+    deliverRemoteDB
-    -- 'allKnown' and 'stillUnknown'. We could be done with DB and proceed to
+        :: OutboxItemId
-    -- launch HTTP requests, but we haven't considered something: Some actors
+        -> [FedURI]
-    -- are known to be unreachable:
+        -> [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, Maybe UTCTime))]
-    --
+        -> AppDB
-    --   (1) There are actors we've never reached, for whom there are pending
+            ( [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, DeliveryId))]
-    --       deliveries
+            , [((InstanceId, Text), NonEmpty (UnfetchedRemoteActorId, LocalURI, UnlinkedDeliveryId))]
-    --   (2) There are actors we already fetched, but for whom there are
+            , [((InstanceId, Text), NonEmpty (UnfetchedRemoteActorId, LocalURI, UnlinkedDeliveryId))]
-    --       pending deliveries because lately their inboxes are unreachable
+            )
-    --
+    deliverRemoteDB obid recips known = do
-    -- And this brings us to 2 potential things to do:
-    --
-    --   (1) Skip the request for some actors, and instead insert a delivery to
-    --       the DB
-    --   (2) Insert/update reachability records for actors we try to reach but
-    --       fail
-    --   (3) Insert/update reachability records for actors we suddenly succeed
-    --       to reach
-    --
-    -- So, for each RemoteActor, we're going to add a field 'errorSince'.
-    -- Its type will be Maybe UTCTime, and the meaning is:
-    --
-    --   - Nothing: We haven't observed the inbox being down
-    --   - Just t: The time t denotes a time we couldn't reach the inbox, and
-    --             since that time all our following attempts failed too
-    --
-    -- In this context, inbox error means any result that isn't a 2xx status.
-    deliverRemote :: Doc Activity -> [FedURI] -> [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI))] -> Handler ()
-    deliverRemote doc recips known = runDB $ do
         recips' <- for (groupByHost recips) $ \ (h, lus) -> do
             let lus' = NE.nub lus
             (iid, inew) <- idAndNew <$> insertBy' (Instance h)
             if inew
-                then return ((iid, h), (Nothing, Just lus'))
+                then return ((iid, h), (Nothing, Nothing, Just lus'))
                 else do
                     es <- for lus' $ \ lu -> do
-                        mers <- getBy $ UniqueRemoteActor iid lu
+                        ma <- runMaybeT
+                            $   Left <$> MaybeT (getBy $ UniqueRemoteActor iid lu)
+                            <|> Right <$> MaybeT (getBy $ UniqueUnfetchedRemoteActor iid lu)
                         return $
-                            case mers of
+                            case ma of
-                                Just (Entity rsid rs) -> Left (rsid, remoteActorInbox rs)
+                                Nothing -> Left lu
-                                Nothing -> Right lu
+                                Just e ->
-                    let (newKnown, unknown) = partitionEithers $ NE.toList es
+                                    Right $ case e of
-                    return ((iid, h), (nonEmpty newKnown, nonEmpty unknown))
+                                        Left (Entity raid ra) -> Left (raid, remoteActorInbox ra, remoteActorErrorSince ra)
-        let moreKnown = mapMaybe (\ (i, (k, _)) -> (i,) <$> k) recips'
+                                        Right (Entity uraid ura) -> Right (uraid, unfetchedRemoteActorIdent ura, unfetchedRemoteActorSince ura)
-            stillUnknown = mapMaybe (\ (i, (_, u)) -> (i,) <$> u) recips'
+                    let (unknown, newKnown) = partitionEithers $ NE.toList es
-            -- ^ [ ( (iid, h) , NonEmpty luActor ) ]
+                        (fetched, unfetched) = partitionEithers newKnown
+                    return ((iid, h), (nonEmpty fetched, nonEmpty unfetched, nonEmpty unknown))
+        let moreKnown = mapMaybe (\ (i, (f, _, _)) -> (i,) <$> f) recips'
+            unfetched = mapMaybe (\ (i, (_, uf, _)) -> (i,) <$> uf) recips'
+            stillUnknown = mapMaybe (\ (i, (_, _, uk)) -> (i,) <$> uk) recips'
             -- TODO see the earlier TODO about merge, it applies here too
-            allKnown = map (second $ NE.nubBy ((==) `on` fst)) $ mergeConcat known moreKnown
+            allFetched = map (second $ NE.nubBy ((==) `on` fst3)) $ mergeConcat known moreKnown
-            -- ^ [ ( (iid, h) , NonEmpty (rsid, inb) ) ]
+        fetchedDeliv <- for allFetched $ \ (i, rs) ->
-        error "TODO CONTINUE"
+            (i,) <$> insertMany' (\ (raid, _, msince) -> Delivery raid obid $ isNothing msince) rs
+        unfetchedDeliv <- for unfetched $ \ (i, rs) ->
+            (i,) <$> insertMany' (\ (uraid, _, msince) -> UnlinkedDelivery uraid obid $ isNothing msince) rs
+        unknownDeliv <- for stillUnknown $ \ (i, lus) -> do
+            -- TODO maybe for URA insertion we should do insertUnique?
+            rs <- insertMany' (\ lu -> UnfetchedRemoteActor (fst i) lu Nothing) lus
+            (i,) <$> insertMany' (\ (_, uraid) -> UnlinkedDelivery uraid obid True) rs
+        return
+            ( takeNoError fetchedDeliv
+            , takeNoError unfetchedDeliv
+            , map
+                (second $ NE.map $ \ ((lu, ak), dlk) -> (ak, lu, dlk))
+                unknownDeliv
+            )
         where
         groupByHost :: [FedURI] -> [(Text, NonEmpty LocalURI)]
         groupByHost = groupAllExtract furiHost (snd . f2l)
+
+        insertMany' mk xs = zip' xs <$> insertMany (NE.toList $ mk <$> xs)
+            where
+            zip' x y =
+                case nonEmpty y of
+                    Just y' | length x == length y' -> NE.zip x y'
+                    _ -> error "insertMany' returned different length!"
+
+        takeNoError = mapMaybe $ \ (i, rs) -> (i,) <$> nonEmpty (mapMaybe noError $ NE.toList rs)
+            where
+            noError ((ak, lu, Nothing), dlk) = Just (ak, lu, dlk)
+            noError ((_ , _ , Just _ ), _  ) = Nothing
+
+    deliverRemoteHttp
+        :: OutboxItemId
+        -> Doc Activity
+        -> ( [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, DeliveryId))]
+           , [((InstanceId, Text), NonEmpty (UnfetchedRemoteActorId, LocalURI, UnlinkedDeliveryId))]
+           , [((InstanceId, Text), NonEmpty (UnfetchedRemoteActorId, LocalURI, UnlinkedDeliveryId))]
+           )
+        -> Handler ()
+    deliverRemoteHttp obid doc (fetched, unfetched, unknown) = do
+        sign <- getHttpSign
+        let deliver = deliverHttp sign doc
+        now <- liftIO getCurrentTime
+        traverse_ (fork . deliverFetched deliver now) fetched
+        traverse_ (fork . deliverUnfetched deliver now) unfetched
+        traverse_ (fork . deliverUnfetched deliver now) unknown
+        where
+        fork = forkHandler $ \ e -> logError $ "Outbox POST handler: delivery failed! " <> T.pack (displayException e)
+        deliverFetched deliver now ((_, h), recips@(r :| rs)) = do
+            let (raid, luInbox, dlid) = r
+            e <- deliver h luInbox
+            let e' = case e of
+                        Left err ->
+                            if isInstanceErrorP err
+                                then Nothing
+                                else Just False
+                        Right _resp -> Just True
+            case e' of
+                Nothing -> runDB $ do
+                    let recips' = NE.toList recips
+                    updateWhere [RemoteActorId <-. map fst3 recips', RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now]
+                    updateWhere [DeliveryId <-. map thd3 recips'] [DeliveryRunning =. False]
+                Just success -> do
+                    runDB $
+                        if success
+                            then delete dlid
+                            else do
+                                updateWhere [RemoteActorId ==. raid, RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now]
+                                update dlid [DeliveryRunning =. False]
+                    for_ rs $ \ (raid, luInbox, dlid) ->
+                        fork $ do
+                            e <- deliver h luInbox
+                            runDB $
+                                case e of
+                                    Left _err -> do
+                                        updateWhere [RemoteActorId ==. raid, RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now]
+                                        update dlid [DeliveryRunning =. False]
+                                    Right _resp -> delete dlid
+        deliverUnfetched deliver now ((iid, h), recips@(r :| rs)) = do
+            let (uraid, luActor, udlid) = r
+            e <- fetchRemoteActor iid h luActor
+            let e' = case e of
+                        Left err ->
+                            if isInstanceErrorG err
+                                then Nothing
+                                else Just Nothing
+                        Right era -> Just $ Just era
+            case e' of
+                Nothing -> runDB $ do
+                    let recips' = NE.toList recips
+                    updateWhere [UnfetchedRemoteActorId <-. map fst3 recips', UnfetchedRemoteActorSince ==. Nothing] [UnfetchedRemoteActorSince =. Just now]
+                    updateWhere [UnlinkedDeliveryId <-. map thd3 recips'] [UnlinkedDeliveryRunning =. False]
+                Just mera -> do
+                    for_ rs $ \ (uraid, luActor, udlid) ->
+                        fork $ do
+                            e <- fetchRemoteActor iid h luActor
+                            case e of
+                                Left _ -> runDB $ do
+                                    updateWhere [UnfetchedRemoteActorId ==. uraid, UnfetchedRemoteActorSince ==. Nothing] [UnfetchedRemoteActorSince =. Just now]
+                                    update udlid [UnlinkedDeliveryRunning =. False]
+                                Right (Entity raid ra) -> do
+                                    e' <- deliver h $ remoteActorInbox ra
+                                    runDB $
+                                        case e' of
+                                            Left _ -> do
+                                                updateWhere [RemoteActorId ==. raid, RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now]
+                                                delete udlid
+                                                insert_ $ Delivery raid obid False
+                                            Right _ -> delete udlid
+                    case mera of
+                        Nothing -> runDB $ do
+                            updateWhere [UnfetchedRemoteActorId ==. uraid, UnfetchedRemoteActorSince ==. Nothing] [UnfetchedRemoteActorSince =. Just now]
+                            update udlid [UnlinkedDeliveryRunning =. False]
+                        Just (Entity raid ra) -> do
+                            e'' <- deliver h $ remoteActorInbox ra
+                            runDB $
+                                case e'' of
+                                    Left _ -> do
+                                        updateWhere [RemoteActorId ==. raid, RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now]
+                                        delete udlid
+                                        insert_ $ Delivery raid obid False
+                                    Right _ -> delete udlid
+
+retryOutboxDelivery :: Handler ()
+retryOutboxDelivery = do
+    now <- liftIO getCurrentTime
+    (udls, dls) <- runDB $ 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` i `E.LeftOuterJoin` ra) -> do
+            E.on $ E.just (ura E.^. UnfetchedRemoteActorInstance) E.==. ra E.?. RemoteActorInstance
+                E.&&. E.just (ura E.^. UnfetchedRemoteActorIdent) E.==. ra E.?. RemoteActorIdent
+            E.on $ ura E.^. UnfetchedRemoteActorInstance E.==. i E.^. InstanceId
+            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 $ ura E.^. UnfetchedRemoteActorInstance, E.asc $ ura E.^. UnfetchedRemoteActorId]
+            return
+                ( i E.^. InstanceId
+                , i E.^. InstanceHost
+                , ura E.^. UnfetchedRemoteActorId
+                , ura E.^. UnfetchedRemoteActorIdent
+                , ura E.^. UnfetchedRemoteActorSince
+                , udl E.^. UnlinkedDeliveryId
+                , udl E.^. UnlinkedDeliveryActivity
+                , ob E.^. OutboxItemActivity
+                , ra E.?. RemoteActorId
+                )
+        -- 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_ $ map 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 <- getsYesod $ 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` i `E.InnerJoin` ob) -> do
+            E.on $ dl E.^. DeliveryActivity E.==. ob E.^. OutboxItemId
+            E.on $ ra E.^. RemoteActorInstance E.==. i E.^. InstanceId
+            E.on $ dl E.^. DeliveryRecipient E.==. ra E.^. RemoteActorId
+            E.where_ $ dl E.^. DeliveryRunning E.==. E.val False
+            E.orderBy [E.asc $ ra E.^. RemoteActorInstance, E.asc $ ra E.^. RemoteActorId]
+            return
+                ( i E.^. InstanceId
+                , i E.^. InstanceHost
+                , ra E.^. RemoteActorId
+                , ra E.^. RemoteActorInbox
+                , ra E.^. RemoteActorErrorSince
+                , dl E.^. DeliveryId
+                , ob E.^. OutboxItemActivity
+                )
+        let (linkedOld, linkedNew) = partitionEithers $ map (decideBySinceDL dropAfter now . adaptLinked) linked
+        deleteWhere [DeliveryId <-. linkedOld]
+        return (groupUnlinked lonelyNew, groupLinked linkedNew)
+    sign <- getHttpSign
+    let deliver = deliverHttp sign
+    waitsDL <- traverse (fork . deliverLinked deliver now) dls
+    waitsUDL <- traverse (fork . deliverUnlinked deliver now) udls
+    resultsDL <- sequence waitsDL
+    unless (and resultsDL) $ logError "Periodic delivery DL error"
+    resultsUDL <- sequence waitsUDL
+    unless (and resultsUDL) $ logError "Periodic delivery UDL error"
+    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 act, E.Value mraid) =
+            ( mraid
+            , ( ( (iid, h)
+                , ((uraid, luRecip), (udlid, obid, persistJSONValue act))
+                )
+              , since
+              )
+            )
+    unlinkedID ((_, (_, (udlid, _, _))), _) = udlid
+    toLinked (raid, ((_, (_, (_, obid, _))), _)) = Delivery raid obid False
+    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
+    groupUnlinked
+        = map (second $ groupWithExtractBy1 ((==) `on` fst) fst snd)
+        . groupWithExtractBy ((==) `on` fst) fst snd
+    adaptLinked
+        (E.Value iid, E.Value h, E.Value raid, E.Value inbox, E.Value since, E.Value dlid, E.Value act) =
+            ( ( (iid, h)
+              , ((raid, inbox), (dlid, persistJSONValue 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
+    groupLinked
+        = map (second $ groupWithExtractBy1 ((==) `on` fst) fst snd)
+        . groupWithExtractBy ((==) `on` fst) fst snd
+    fork action = do
+        mvar <- liftIO newEmptyMVar
+        let handle e = do
+                liftIO $ putMVar mvar False
+                logError $ "Periodic delivery error! " <> T.pack (displayException e)
+        forkHandler handle $ do
+            success <- action
+            liftIO $ putMVar mvar success
+        return $ liftIO $ readMVar mvar
+    deliverLinked deliver now ((_, h), recips) = do
+        waitsR <- for recips $ \ ((raid, inbox), delivs) -> fork $ do
+            waitsD <- for delivs $ \ (dlid, doc) -> fork $ do
+                e <- deliver doc h inbox
+                case e of
+                    Left _err -> return False
+                    Right _resp -> do
+                        runDB $ delete dlid
+                        return True
+            results <- sequence waitsD
+            runDB $
+                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 " <> h
+        return True
+    deliverUnlinked deliver now ((iid, h), recips) = do
+        waitsR <- for recips $ \ ((uraid, luRecip), delivs) -> fork $ do
+            e <- fetchRemoteActor iid h luRecip
+            case e of
+                Left _ -> runDB $ updateWhere [UnfetchedRemoteActorId ==. uraid, UnfetchedRemoteActorSince ==. Nothing] [UnfetchedRemoteActorSince =. Just now]
+                Right (Entity raid ra) -> do
+                    waitsD <- for delivs $ \ (udlid, obid, doc) -> fork $ do
+                        e' <- deliver doc h $ remoteActorInbox ra
+                        case e' of
+                            Left _err -> do
+                                runDB $ do
+                                    delete udlid
+                                    insert_ $ Delivery raid obid False
+                                return False
+                            Right _resp -> do
+                                runDB $ delete udlid
+                                return True
+                    results <- sequence waitsD
+                    runDB $
+                        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 UDL delivery error for host " <> h
+        return True

src/Vervis/Foundation.hs

@@ -64,6 +64,7 @@ import Yesod.Mail.Send
 
 import qualified Network.HTTP.Signature as S (Algorithm (..))
 
+import Control.Concurrent.ResultShare
 import Crypto.PublicVerifKey
 import Network.FedURI
 import Web.ActivityAccess
@@ -104,6 +105,7 @@ data App = App
     , appInstanceMutex :: InstanceMutex
     , appCapSignKey   :: AccessTokenSecretKey
     , appHashidsContext :: HashidsContext
+    , appActorFetchShare :: ResultShare (HandlerFor App) FedURI (Either (Maybe APGetError) (Entity RemoteActor)) InstanceId
 
     , appActivities  :: TVar (Vector (UTCTime, ActivityReport))
     }
@@ -625,6 +627,7 @@ instance YesodRemoteActorStore App where
     siteInstanceRoomMode = appMaxInstanceKeys . appSettings
     siteActorRoomMode    = appMaxActorKeys . appSettings
     siteRejectOnMaxKeys  = appRejectOnMaxKeys . appSettings
+    siteActorFetchShare  = appActorFetchShare
 
 data ActorDetail = ActorDetail
     { actorDetailId       :: FedURI

src/Vervis/Migration.hs

@@ -243,6 +243,8 @@ changes =
         "RemoteActor"
         (Nothing :: Maybe UTCTime)
         "errorSince"
+      -- 59
+    , addEntities model_2019_04_12
     ]
 
 migrateDB :: MonadIO m => ReaderT SqlBackend m (Either Text (Int, Int))

src/Vervis/Migration/Model.hs

@@ -36,6 +36,7 @@ module Vervis.Migration.Model
     , FollowerSet2019Generic (..)
     , Ticket2019
     , model_2019_04_11
+    , model_2019_04_12
     )
 where
 
@@ -94,3 +95,6 @@ makeEntitiesMigration "2019"
 
 model_2019_04_11 :: [Entity SqlBackend]
 model_2019_04_11 = $(schema "2019_04_11")
+
+model_2019_04_12 :: [Entity SqlBackend]
+model_2019_04_12 = $(schema "2019_04_12")

src/Vervis/RemoteActorStore.hs

@@ -23,6 +23,9 @@ module Vervis.RemoteActorStore
     , keyListedByActorShared
     , VerifKeyDetail (..)
     , addVerifKey
+    , actorFetchShareSettings
+    , fetchRemoteActor
+    , deleteUnusedURAs
     )
 where
 
@@ -46,11 +49,12 @@ import Database.Persist
 import Database.Persist.Sql
 import Network.HTTP.Client
 import UnliftIO.MVar (withMVar)
-import Yesod.Core hiding (logError)
+import Yesod.Core hiding (logWarn, logError)
 import Yesod.Persist.Core
 
 import qualified Data.HashMap.Strict as M
 import qualified Data.Text as T
+import qualified Database.Esqueleto as E
 
 import Crypto.PublicVerifKey
 import Database.Persist.Local
@@ -78,7 +82,7 @@ class Yesod site => YesodRemoteActorStore site where
     siteActorRoomMode    :: site -> Maybe Int
     siteRejectOnMaxKeys  :: site -> Bool
 
-    siteActorFetchShare  :: site -> ResultShare (HandlerFor site) FedURI (Either String (Entity RemoteActor)) InstanceId
+    siteActorFetchShare  :: site -> ResultShare (HandlerFor site) FedURI (Either (Maybe APGetError) (Entity RemoteActor)) InstanceId
 
 -- TODO this is copied from stm-2.5, remove when we upgrade LTS
 stateTVar :: TVar s -> (s -> (a, s)) -> STM a
@@ -452,7 +456,7 @@ actorFetchShareSettings
        , BaseBackend (YesodPersistBackend site) ~ SqlBackend
        , HasHttpManager site
        )
-    => ResultShareSettings (HandlerFor site) FedURI (Either String (Entity RemoteActor)) InstanceId
+    => ResultShareSettings (HandlerFor site) FedURI (Either (Maybe APGetError) (Entity RemoteActor)) InstanceId
 actorFetchShareSettings = ResultShareSettings
     { resultShareFork   = forkHandler $ \ e -> logError $ "ActorFetchShare action failed! " <> T.pack (displayException e)
     , resultShareAction = \ u iid -> do
@@ -462,7 +466,7 @@ actorFetchShareSettings = ResultShareSettings
             Just ers -> return $ Right ers
             Nothing -> do
                 manager <- getsYesod getHttpManager
-                eactor <- fetchAPID manager actorId h lu
+                eactor <- fetchAPID' manager actorId h lu
                 for eactor $ \ actor -> runDB $
                     insertEntity $ RemoteActor lu iid (actorInbox actor) Nothing
     }
@@ -473,7 +477,7 @@ fetchRemoteActor
        , BaseBackend (YesodPersistBackend site) ~ SqlBackend
        , YesodRemoteActorStore site
        )
-    => InstanceId -> Text -> LocalURI -> HandlerFor site (Either String (Entity RemoteActor))
+    => InstanceId -> Text -> LocalURI -> HandlerFor site (Either (Maybe APGetError) (Entity RemoteActor))
 fetchRemoteActor iid host luActor = do
     mers <- runDB $ getBy $ UniqueRemoteActor iid luActor
     case mers of
@@ -481,3 +485,12 @@ fetchRemoteActor iid host luActor = do
         Nothing -> do
             afs <- getsYesod siteActorFetchShare
             runShared afs (l2f host luActor) iid
+
+deleteUnusedURAs = do
+    uraids <- E.select $ E.from $ \ ura -> do
+        E.where_ $ E.notExists $ E.from $ \ udl ->
+            E.where_ $ ura E.^. UnfetchedRemoteActorId E.==. udl E.^. UnlinkedDeliveryRecipient
+        return $ ura E.^. UnfetchedRemoteActorId
+    unless (null uraids) $ do
+        deleteWhere [UnfetchedRemoteActorId <-. map E.unValue uraids]
+        logWarn $ T.pack (show $ length uraids) <> " unused URAs deleted"

src/Web/ActivityPub.hs

@@ -53,6 +53,7 @@ module Web.ActivityPub
     , httpPostAP
     , Fetched (..)
     , fetchAPID
+    , fetchAPID'
     , keyListedByActor
     , fetchUnknownKey
     , fetchKnownPersonalKey
@@ -680,8 +681,11 @@ data Fetched = Fetched
       --   we received.
     }
 
+fetchAP' :: (MonadIO m, FromJSON a) => Manager -> FedURI -> ExceptT APGetError m a
+fetchAP' m u = ExceptT $ second responseBody <$> httpGetAP m u
+
 fetchAP :: (MonadIO m, FromJSON a) => Manager -> FedURI -> ExceptT String m a
-fetchAP m u = ExceptT $ bimap displayException responseBody <$> httpGetAP m u
+fetchAP m u = withExceptT displayException $ fetchAP' m u
 
 {-
 fetchAPH :: (MonadIO m, ActivityPub a) => Manager -> Text -> LocalURI -> ExceptT String m a
@@ -692,12 +696,18 @@ fetchAPH m h lu = do
         else throwE "Object @id URI's host doesn't match the URI we fetched"
 -}
 
-fetchAPID :: (MonadIO m, ActivityPub a) => Manager -> (a -> LocalURI) -> Text -> LocalURI -> m (Either String a)
+fetchAPID' :: (MonadIO m, ActivityPub a) => Manager -> (a -> LocalURI) -> Text -> LocalURI -> m (Either (Maybe APGetError) a)
-fetchAPID m getId h lu = runExceptT $ do
+fetchAPID' m getId h lu = runExceptT $ do
-    Doc h' v <- fetchAP m $ l2f h lu
+    Doc h' v <- withExceptT Just $ fetchAP' m $ l2f h lu
     if h == h' && getId v == lu
         then return v
-        else throwE "Object @id doesn't match the URI we fetched"
+        else throwE Nothing
+
+fetchAPID :: (MonadIO m, ActivityPub a) => Manager -> (a -> LocalURI) -> Text -> LocalURI -> m (Either String a)
+fetchAPID m getId h lu = first showError <$> fetchAPID' m getId h lu
+    where
+    showError Nothing  = "Object @id doesn't match the URI we fetched"
+    showError (Just e) = displayException e
 
 fetchAPIDOrH
     :: (MonadIO m, ActivityPub a, ActivityPub b)

vervis.cabal

@@ -337,6 +337,7 @@ library
                      , time-interval
                      , time-interval-aeson
                      , time-units
+                     , tls
                      , transformers
                        -- probably should be replaced with lenses once I learn
                      , tuple