{- This file is part of Vervis.
 -
 - Written in 2019, 2020, 2021, 2022, 2023
 - by fr33domlover <fr33domlover@riseup.net>.
 -
 - ♡ Copying is an act of love. Please copy, reuse and share.
 -
 - The author(s) have dedicated all copyright and related and neighboring
 - rights to this software to the public domain worldwide. This software is
 - distributed without any warranty.
 -
 - You should have received a copy of the CC0 Public Domain Dedication along
 - with this software. If not, see
 - <http://creativecommons.org/publicdomain/zero/1.0/>.
 -}

module Vervis.Web.Delivery
    ( -- prepareResendP
    --, prepareResendH

    --, forwardRemoteDB
    --, forwardRemoteHttp
    --, deliverRemoteDB
    --, deliverRemoteHttp
    --, deliverLocal'
    --, deliverLocal
    --, insertRemoteActivityToLocalInboxes
    --fixRunningDeliveries
    --, retryOutboxDelivery

      deliverActivityDB
    , forwardActivityDB
    )
where

import Control.Applicative
import Control.Concurrent.Chan
import Control.Concurrent.STM.TVar
import Control.Exception hiding (Handler, try)
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.IO.Unlift
import Control.Monad.Logger.CallStack
import Control.Monad.Trans.Class
import Control.Monad.Trans.Except
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Reader
import Data.Bifunctor
import Data.Bitraversable
import Data.ByteString (ByteString)
import Data.Either
import Data.Foldable
import Data.Function
import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
import Data.Maybe
import Data.Text (Text)
import Data.Time.Clock
import Data.Traversable
import Database.Persist
import Database.Persist.Sql
import Yesod.Core hiding (logError, logWarn, logInfo, logDebug)

import qualified Data.ByteString.Lazy as BL
import qualified Data.HashMap.Strict as HM
import qualified Data.HashSet as HS
import qualified Data.List.NonEmpty as NE
import qualified Data.List.Ordered as LO
import qualified Data.Text as T
import qualified Database.Esqueleto as E

import Control.Concurrent.Actor
import Crypto.ActorKey
import Database.Persist.JSON
import Network.FedURI
import Yesod.ActivityPub
import Yesod.MonadSite
import Yesod.Hashids

import qualified Web.ActivityPub as AP

import Data.List.NonEmpty.Local
import Data.Maybe.Local
import Data.Tuple.Local
import Database.Persist.Local

import Vervis.Actor (Event)
import Vervis.ActivityPub
import Vervis.Data.Actor
import Vervis.FedURI
import Vervis.Foundation
import Vervis.Model
import Vervis.Persist.Actor
import Vervis.Recipient
import Vervis.RemoteActorStore
import Vervis.Settings

prepareResendIK
    :: (MonadSite m, SiteEnv m ~ App)
    => (Route App, ActorKey)
    -> LocalActorBy KeyHashid
    -> BL.ByteString
    -> m (AP.Envelope URIMode)
prepareResendIK (keyR, akey) holderByHash body = do
    let sign = actorKeySign akey
        holderR = renderLocalActor holderByHash
    prepareToRetry keyR sign (Just holderR) body

prepareResendAK
    :: (MonadSite m, SiteEnv m ~ App)
    => ActorId
    -> LocalActorBy KeyHashid
    -> BL.ByteString
    -> ReaderT SqlBackend m (AP.Envelope URIMode)
prepareResendAK actorID actorByHash body = do
    Entity keyID key <- do
        mk <- getBy $ UniqueSigKey actorID
        case mk of
            Nothing -> error "Actor has no keys!"
            Just k -> return k
    keyHash <- encodeKeyHashid keyID
    let keyR = stampRoute actorByHash keyHash
        sign = actorKeySign $ sigKeyMaterial key
    prepareToRetry keyR sign Nothing body

{-
prepareResendP
    :: (MonadSite m, SiteEnv m ~ App)
    => ActorId
    -> LocalActorBy KeyHashid
    -> BL.ByteString
    -> ReaderT SqlBackend m (AP.Envelope URIMode)
prepareResendP actorID holderByHash body = do
    maybeKey <- lift askLatestInstanceKey
    case maybeKey of
        Nothing -> prepareResendAK actorID holderByHash body
        Just key -> lift $ prepareResendIK key holderByHash body
-}

{-
prepareResendH
    :: (MonadUnliftIO m, MonadSite m, SiteEnv m ~ App)
    => ActorId
    -> LocalActorBy KeyHashid
    -> BL.ByteString
    -> m (AP.Envelope URIMode)
prepareResendH actorID holderByHash body = do
    maybeKey <- askLatestInstanceKey
    case maybeKey of
        Nothing -> runSiteDB $ prepareResendAK actorID holderByHash body
        Just key -> prepareResendIK key holderByHash body

forwardRemoteDB
    :: MonadIO m
    => BL.ByteString
    -> RemoteActivityId
    -> ActorId
    -> ByteString
    -> [((InstanceId, Host), NonEmpty RemoteRecipient)]
    -> ReaderT SqlBackend m
        [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId))]
forwardRemoteDB body ractid fwderID sig recips = do
    let body' = BL.toStrict body
        makeFwd (RemoteRecipient raid _ _ msince) =
            Forwarding raid ractid body' sig fwderID (isNothing msince)
    fetchedDeliv <- for recips $ bitraverse pure (insertMany' makeFwd)
    return $ takeNoError4 fetchedDeliv
    where
    takeNoError noError = mapMaybe $ \ (i, rs) -> (i,) <$> nonEmpty (mapMaybe noError $ NE.toList rs)
    takeNoError4 = takeNoError noError
        where
        noError (RemoteRecipient ak luA luI Nothing , fwid) = Just (ak, luA, luI, fwid)
        noError (RemoteRecipient _  _   _   (Just _), _   ) = Nothing

forwardRemoteHttp
    :: (MonadSite m, SiteEnv m ~ App)
    => UTCTime
    -> AP.Errand URIMode
    -> [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId))]
    -> m ()
forwardRemoteHttp now errand fetched = do
    let deliver h inbox = forwardActivity errand $ ObjURI h inbox
    traverse_ (fork . deliverFetched deliver now) fetched
    where
    fork = forkWorker "Inbox forwarding to remote members of local collections: delivery failed"
    deliverFetched deliver now ((_, h), recips@(r :| rs)) = do
        let (raid, _luActor, luInbox, fwid) = 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 -> runSiteDB $ do
                let recips' = NE.toList recips
                updateWhere [RemoteActorId <-. map fst4 recips', RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now]
                updateWhere [ForwardingId <-. map fourth4 recips'] [ForwardingRunning =. False]
            Just success -> do
                runSiteDB $
                    if success
                        then delete fwid
                        else do
                            updateWhere [RemoteActorId ==. raid, RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now]
                            update fwid [ForwardingRunning =. False]
                for_ rs $ \ (raid, _luActor, luInbox, fwid) ->
                    fork $ do
                        e <- deliver h luInbox
                        runSiteDB $
                            case e of
                                Left _err -> do
                                    updateWhere [RemoteActorId ==. raid, RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now]
                                    update fwid [ForwardingRunning =. False]
                                Right _resp -> delete fwid

data Recip
    = RecipRA (Entity RemoteActor)
    | RecipURA (Entity UnfetchedRemoteActor)
    | RecipRC (Entity RemoteCollection)

deliverRemoteDB
    :: MonadIO m
    => [Host]
    -> OutboxItemId
    -> [(Host, NonEmpty LocalURI)]
    -> [((InstanceId, Host), NonEmpty RemoteRecipient)]
    -> ReaderT SqlBackend m
        ( [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, DeliveryId))]
        , [((InstanceId, Host), NonEmpty (UnfetchedRemoteActorId, LocalURI, UnlinkedDeliveryId))]
        , [((InstanceId, Host), NonEmpty (UnfetchedRemoteActorId, LocalURI, UnlinkedDeliveryId))]
        )
deliverRemoteDB hContexts obid recips known = do
    recips' <- for recips $ \ (h, lus) -> do
        let lus' = NE.nub lus
        (iid, inew) <- idAndNew <$> insertBy' (Instance h)
        if inew
            then return ((iid, h), (Nothing, Nothing, Just lus'))
            else do
                es <- for lus' $ \ lu -> do
                    ma <- runMaybeT $ do
                        Entity roid ro <- MaybeT $ getBy $ UniqueRemoteObject iid lu
                        recip <- RecipRA <$> MaybeT (getBy $ UniqueRemoteActor roid)
                             <|> RecipURA <$> MaybeT (getBy $ UniqueUnfetchedRemoteActor roid)
                             <|> RecipRC <$> MaybeT (getBy $ UniqueRemoteCollection roid)
                        return (ro, recip)
                    return $
                        case ma of
                            Nothing -> Just $ Left lu
                            Just (ro, r) ->
                                case r of
                                    RecipRA (Entity raid ra) -> Just $ Right $ Left $ RemoteRecipient raid (remoteObjectIdent ro) (remoteActorInbox ra) (remoteActorErrorSince ra)
                                    RecipURA (Entity uraid ura) -> Just $ Right $ Right (uraid, remoteObjectIdent ro, unfetchedRemoteActorSince ura)
                                    RecipRC _ -> Nothing
                let (unknown, newKnown) = partitionEithers $ catMaybes $ NE.toList es
                    (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'
        allFetched = unionRemotes known moreKnown
    fetchedDeliv <- for allFetched $ \ (i, rs) ->
        let fwd = snd i `elem` hContexts
        in  (i,) <$> insertMany' (\ (RemoteRecipient raid _ _ msince) -> Delivery raid obid fwd $ isNothing msince) rs
    unfetchedDeliv <- for unfetched $ \ (i, rs) ->
        let fwd = snd i `elem` hContexts
        in  (i,) <$> insertMany' (\ (uraid, _, msince) -> UnlinkedDelivery uraid obid fwd $ isNothing msince) rs
    unknownDeliv <- for stillUnknown $ \ (i, lus) -> do
        -- TODO maybe for URA insertion we should do insertUnique?
        ros <- insertMany' (\ lu -> RemoteObject (fst i) lu) lus
        rs <- insertMany' (\ (_lu, roid) -> UnfetchedRemoteActor roid Nothing) ros
        let fwd = snd i `elem` hContexts
        (i,) <$> insertMany' (\ (_, uraid) -> UnlinkedDelivery uraid obid fwd True) rs
    return
        ( takeNoError4 fetchedDeliv
        , takeNoError3 unfetchedDeliv
        , map
            (second $ NE.map $ \ (((lu, _roid), ak), dlk) -> (ak, lu, dlk))
            unknownDeliv
        )
    where
    takeNoError noError = mapMaybe $ \ (i, rs) -> (i,) <$> nonEmpty (mapMaybe noError $ NE.toList rs)
    takeNoError3 = takeNoError noError
        where
        noError ((ak, lu, Nothing), dlk) = Just (ak, lu, dlk)
        noError ((_ , _ , Just _ ), _  ) = Nothing
    takeNoError4 = takeNoError noError
        where
        noError (RemoteRecipient ak luA luI Nothing , dlk) = Just (ak, luA, luI, dlk)
        noError (RemoteRecipient _  _   _   (Just _), _  ) = Nothing

deliverRemoteHttp
    :: [Host]
    -> OutboxItemId
    -> AP.Envelope URIMode
    -> ( [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, DeliveryId))]
       , [((InstanceId, Host), NonEmpty (UnfetchedRemoteActorId, LocalURI, UnlinkedDeliveryId))]
       , [((InstanceId, Host), NonEmpty (UnfetchedRemoteActorId, LocalURI, UnlinkedDeliveryId))]
       )
    -> Worker ()
deliverRemoteHttp hContexts obid envelope (fetched, unfetched, unknown) = do
    logDebug' "Starting"
    let deliver fwd h inbox = do
            let fwd' = if h `elem` hContexts then Just fwd else Nothing
            (isJust fwd',) <$> deliverActivity envelope fwd' (ObjURI h inbox)
    now <- liftIO getCurrentTime
    logDebug' $
        "Launching fetched " <> showHosts fetched
    traverse_ (fork . deliverFetched deliver now) fetched
    logDebug' $
        "Launching unfetched " <> showHosts unfetched
    traverse_ (fork . deliverUnfetched deliver now) unfetched
    logDebug' $
        "Launching unknown " <> showHosts unknown
    traverse_ (fork . deliverUnfetched deliver now) unknown
    logDebug' "Done (async delivery may still be running)"
    where
    showHosts = T.pack . show . map (renderAuthority . snd . fst)
    logDebug' t = logDebug $ prefix <> t
        where
        prefix =
            T.concat
                [ "Outbox POST handler: deliverRemoteHttp obid#"
                , "?" --T.pack $ show $ fromSqlKey obid
                , ": "
                ]
    fork = forkWorker "Outbox POST handler: HTTP delivery"
    deliverFetched deliver now ((_, h), recips@(r :| rs)) = do
        logDebug'' "Starting"
        let (raid, luActor, luInbox, dlid) = r
        (_, e) <- deliver luActor h luInbox
        e' <- case e of
                Left err -> do
                    logError $ T.concat
                        [ "Outbox DL delivery #", T.pack $ show dlid
                        , " error for <", renderObjURI $ ObjURI h luActor
                        , ">: ",  T.pack $ displayException err
                        ]
                    return $
                        if isInstanceErrorP err
                            then Nothing
                            else Just False
                Right _resp -> return $ Just True
        case e' of
            Nothing -> runSiteDB $ do
                let recips' = NE.toList recips
                updateWhere [RemoteActorId <-. map fst4 recips', RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now]
                updateWhere [DeliveryId <-. map fourth4 recips'] [DeliveryRunning =. False]
            Just success -> do
                runSiteDB $
                    if success
                        then delete dlid
                        else do
                            updateWhere [RemoteActorId ==. raid, RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now]
                            update dlid [DeliveryRunning =. False]
                for_ rs $ \ (raid, luActor, luInbox, dlid) ->
                    fork $ do
                        (_, e) <- deliver luActor h luInbox
                        runSiteDB $
                            case e of
                                Left err -> do
                                    logError $ T.concat
                                        [ "Outbox DL delivery #", T.pack $ show dlid
                                        , " error for <", renderObjURI $ ObjURI h luActor
                                        , ">: ",  T.pack $ displayException err
                                        ]
                                    updateWhere [RemoteActorId ==. raid, RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now]
                                    update dlid [DeliveryRunning =. False]
                                Right _resp -> delete dlid
        where
        logDebug'' t = logDebug' $ T.concat ["deliverFetched ", renderAuthority h, t]
    deliverUnfetched deliver now ((iid, h), recips@(r :| rs)) = do
        logDebug'' "Starting"
        let (uraid, luActor, udlid) = r
        e <- fetchRemoteActor iid h luActor
        let e' = case e of
                    Left err -> Just Nothing
                    Right (Left err) ->
                        if isInstanceErrorG err
                            then Nothing
                            else Just Nothing
                    Right (Right mera) -> Just $ Just mera
        case e' of
            Nothing -> runSiteDB $ do
                let recips' = NE.toList recips
                updateWhere [UnfetchedRemoteActorId <-. map fst3 recips', UnfetchedRemoteActorSince ==. Nothing] [UnfetchedRemoteActorSince =. Just now]
                updateWhere [UnlinkedDeliveryId <-. map thd3 recips'] [UnlinkedDeliveryRunning =. False]
            Just mmera -> do
                for_ rs $ \ (uraid, luActor, udlid) ->
                    fork $ do
                        e <- fetchRemoteActor iid h luActor
                        case e of
                            Right (Right mera) ->
                                case mera of
                                    Nothing -> runSiteDB $ delete udlid
                                    Just (Entity raid ra) -> do
                                        (fwd, e') <- deliver luActor h $ remoteActorInbox ra
                                        runSiteDB $
                                            case e' of
                                                Left _ -> do
                                                    updateWhere [RemoteActorId ==. raid, RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now]
                                                    delete udlid
                                                    insert_ $ Delivery raid obid fwd False
                                                Right _ -> delete udlid
                            _ -> runSiteDB $ do
                                updateWhere [UnfetchedRemoteActorId ==. uraid, UnfetchedRemoteActorSince ==. Nothing] [UnfetchedRemoteActorSince =. Just now]
                                update udlid [UnlinkedDeliveryRunning =. False]
                case mmera of
                    Nothing -> runSiteDB $ do
                        updateWhere [UnfetchedRemoteActorId ==. uraid, UnfetchedRemoteActorSince ==. Nothing] [UnfetchedRemoteActorSince =. Just now]
                        update udlid [UnlinkedDeliveryRunning =. False]
                    Just mera ->
                        case mera of
                            Nothing -> runSiteDB $ delete udlid
                            Just (Entity raid ra) -> do
                                (fwd, e'') <- deliver luActor h $ remoteActorInbox ra
                                runSiteDB $
                                    case e'' of
                                        Left _ -> do
                                            updateWhere [RemoteActorId ==. raid, RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now]
                                            delete udlid
                                            insert_ $ Delivery raid obid fwd False
                                        Right _ -> delete udlid
        where
        logDebug'' t = logDebug' $ T.concat ["deliverUnfetched ", renderAuthority h, t]

-- | Given a list of local recipients, which may include actors and
-- collections,
--
-- * Insert activity to message queues of live local actors
-- * If collections are listed, insert activity to message queues of local
--   members and return the remote members
deliverLocal'
    :: (MonadSite m, YesodHashids (SiteEnv m), SiteEnv m ~ App)
    => Bool -- ^ Whether to deliver to collection only if owner actor is addressed
    -> LocalActorBy Key
    -> LocalActorBy Key
    -> Event
    -> RecipientRoutes
    -> ReaderT SqlBackend m [((InstanceId, Host), NonEmpty RemoteRecipient)]
deliverLocal' requireOwner author aidAuthor event =
    insertActivityToLocalInboxes event requireOwner (Just author) (Just aidAuthor)

-- | Given a list of local recipients, which may include actors and
-- collections,
--
-- * Insert activity to queues of actors
-- * If the author's follower collection is listed, insert activity to queues
--   of the local members and return the remote members
-- * Ignore other collections
deliverLocal
    :: PersonId
    -> Event
    -> RecipientRoutes
    -> AppDB
        [ ( (InstanceId, Host)
          , NonEmpty RemoteRecipient
          )
        ]
deliverLocal authorID event recips = do
    authorHash <- encodeKeyHashid authorID
    let sieve =
            RecipientRoutes [(authorHash, PersonRoutes False True)] [] [] [] []
        author = LocalActorPerson authorID
    deliverLocal' True author author event $ localRecipSieve sieve True recips

insertRemoteActivityToLocalInboxes
    :: (MonadSite m, YesodHashids (SiteEnv m), SiteEnv m ~ App)
    => Bool
    -> Event
    -> RecipientRoutes
    -> ReaderT SqlBackend m [((InstanceId, Host), NonEmpty RemoteRecipient)]
insertRemoteActivityToLocalInboxes requireOwner event =
    insertActivityToLocalInboxes event requireOwner Nothing Nothing
-}

{-
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"
        ]
-}

{-
relevant dropAfter now since = addUTCTime dropAfter since > now

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

retryUnlinkedDelivery :: Worker ()
retryUnlinkedDelivery = do
    now <- liftIO $ getCurrentTime
    unlinkedHttp <- runSiteDB $ do

        -- Get all unlinked deliveries which aren't running already in outbox
        -- post handlers
        unlinked' <- E.select $ E.from $
            \ (udl `E.InnerJoin` obi `E.InnerJoin` a `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 $ obi E.^. OutboxItemOutbox E.==. a E.^. ActorOutbox
            E.on $ udl E.^. UnlinkedDeliveryActivity E.==. obi 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
                , ura E.^. UnfetchedRemoteActorId
                , ro E.^. RemoteObjectIdent
                , ura E.^. UnfetchedRemoteActorSince
                , udl E.^. UnlinkedDeliveryId
                , udl E.^. UnlinkedDeliveryActivity
                , udl E.^. UnlinkedDeliveryForwarding
                , obi E.^. OutboxItemActivity
                , ra E.?. RemoteActorId
                , rc E.?. RemoteCollectionId
                , a E.^. ActorId
                )

        -- Strip the E.Value wrappers and organize the records for the
        -- filtering and grouping we'll need to do
        unlinked <- traverse adaptUnlinked unlinked'

        -- Split into found (recipient has been reached) and lonely (recipient
        -- hasn't been reached)
        let (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]

        return $ groupUnlinked lonelyNew

    logDebug $
        "Periodic delivery forking unlinked " <>
        T.pack (show $ map (renderAuthority . snd . fst) unlinkedHttp)
    waitsUDL <- traverse (fork . deliverUnlinked now) unlinkedHttp

    logDebug $
        T.concat
            [ "Periodic delivery waiting for "
            , T.pack $ show $ length waitsUDL, " unlinked"
            ]
    resultsUDL <- sequence waitsUDL
    unless (and resultsUDL) $ logError "Periodic delivery UDL error"

    where

    adaptUnlinked (Entity iid (Instance 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, E.Value actorID) = do
        actorByKey <- getLocalActor actorID
        return
            ( Left <$> mraid <|> Right <$> mrcid
            , ( ( (iid, h)
                , ( (uraid, luRecip)
                  , ( udlid
                    , fwd
                    , obid
                    , BL.fromStrict $ persistJSONBytes act
                    , actorID
                    , actorByKey
                    )
                  )
                )
              , since
              )
            )

    unlinkedID ((_, (_, (udlid, _, _, _, _, _))), _) = udlid

    toLinked (Left raid, ((_, (_, (_, fwd, obid, _, _, _))), _)) = Just $ Delivery raid obid fwd False
    toLinked (Right _  , _                                     ) = Nothing

    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

    deliverUnlinked 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 fst6 (NE.toList delivs)]
                        Just (Entity raid ra) -> do
                            waitsD <- for delivs $ \ (udlid, fwd, obid, doc, actorID, actorByKey) -> fork $ do
                                actorByHash <- hashLocalActor actorByKey
                                envelope <- prepareResendH actorID actorByHash doc
                                let fwd' = if fwd then Just luRecip else Nothing
                                e' <- deliverActivity envelope fwd' (ObjURI 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

retryLinkedDelivery :: Worker ()
retryLinkedDelivery = do
    now <- liftIO $ getCurrentTime
    linkedHttp <- runSiteDB $ do

        -- 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` obi `E.InnerJoin` a) -> do
            E.on $ obi E.^. OutboxItemOutbox E.==. a E.^. ActorOutbox
            E.on $ dl E.^. DeliveryActivity E.==. obi 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
                , obi E.^. OutboxItemActivity
                , a E.^. ActorId
                )
        dropAfter <- lift $ asksSite $ appDropDeliveryAfter . appSettings
        linked' <- traverse adaptLinked linked
        let (linkedOld, linkedNew) =
                partitionEithers $ map (decideBySinceDL dropAfter now) linked'
        deleteWhere [DeliveryId <-. linkedOld]

        return $ groupLinked linkedNew

    logDebug $
        "Periodic delivery forking linked " <>
        T.pack (show $ map (renderAuthority . snd . fst) linkedHttp)
    waitsDL <- traverse (fork . deliverLinked now) linkedHttp

    logDebug $
        T.concat
            [ "Periodic delivery waiting for ", T.pack $ show $ length waitsDL
            , " linked"
            ]
    resultsDL <- sequence waitsDL
    unless (and resultsDL) $ logError "Periodic delivery DL error"

    where

    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, E.Value actorID) = do
        actorByKey <- getLocalActor actorID
        return
            ( ( (iid, h)
              , ( (raid, (ident, inbox))
                , ( dlid
                  , fwd
                  , BL.fromStrict $ persistJSONBytes act
                  , actorID
                  , actorByKey
                  )
                )
              )
            , 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

    deliverLinked 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, actorID, actorByKey) -> fork $ do
                actorByHash <- hashLocalActor actorByKey
                envelope <- prepareResendH actorID actorByHash doc
                let fwd' = if fwd then Just ident else Nothing
                e <- deliverActivity envelope fwd' (ObjURI 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

retryForwarding :: Worker ()
retryForwarding = do
    now <- liftIO $ getCurrentTime
    forwardingHttp <- runSiteDB $ do

        -- Same for forwarding deliveries, which are always linked
        forwarding <- E.select $ E.from $
            \ (fw `E.InnerJoin` ra `E.InnerJoin` ro `E.InnerJoin` i) -> do
            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)
        dropAfter <- lift $ asksSite $ appDropDeliveryAfter . appSettings
        forwarding' <- traverse adaptForwarding forwarding
        let (forwardingOld, forwardingNew) =
                partitionEithers $
                    map (decideBySinceFW dropAfter now) forwarding'
        deleteWhere [ForwardingId <-. forwardingOld]

        return $ groupForwarding forwardingNew

    logDebug $
        "Periodic delivery forking forwarding " <>
        T.pack (show $ map (renderAuthority . snd . fst) forwardingHttp)
    waitsFW <- traverse (fork . deliverForwarding now) forwardingHttp

    logDebug $
        T.concat
            [ "Periodic delivery waiting for ", T.pack $ show $ length waitsFW
            , " forwarding"
            ]
    resultsFW <- sequence waitsFW
    unless (and resultsFW) $ logError "Periodic delivery FW error"

    where

    adaptForwarding
        ( Entity iid (Instance h)
        , Entity raid (RemoteActor _ _ inbox _ since)
        , Entity fwid (Forwarding _ _ body sig fwderID _)
        ) = do
            actorByKey <- getLocalActor fwderID
            return
                ( ( (iid, h)
                  , ( (raid, inbox)
                    , ( fwid
                      , BL.fromStrict body
                      , actorByKey
                      , sig
                      , fwderID
                      )
                    )
                  )
                , since
                )

    decideBySinceFW dropAfter now (fw@(_, (_, (fwid, _, _, _, _))), msince) =
        case msince of
            Nothing -> Right fw
            Just since ->
                if relevant dropAfter now since
                    then Right fw
                    else Left fwid

    groupForwarding
        = map (second $ groupWithExtractBy1 ((==) `on` fst) fst snd)
        . groupWithExtractBy ((==) `on` fst) fst snd

    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, fwderByKey, sig, fwderActorID) -> fork $ do
                fwderByHash <- hashLocalActor fwderByKey
                errand <- prepareForwardH fwderActorID fwderByHash body sig
                let sender = renderLocalActor fwderByHash
                e <- forwardActivity errand $ ObjURI h inbox
                case e of
                    Left _err -> return False
                    Right _resp -> do
                        runSiteDB $ 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

retryOutboxDelivery :: Worker ()
retryOutboxDelivery = do
    logInfo "Periodic delivery starting"

    retryUnlinkedDelivery
    retryLinkedDelivery
    retryForwarding

    logInfo "Periodic delivery done"
-}

deliverActivityDB
    :: (MonadSite m, SiteEnv m ~ App)
    => LocalActorBy KeyHashid
    -> ActorId
    -> RecipientRoutes
    -> [(Host, NonEmpty LocalURI)]
    -> [Host]
    -> OutboxItemId
    -> AP.Action URIMode
    -> ExceptT Text (ReaderT SqlBackend m) (Worker ())
deliverActivityDB senderByHash senderActorID localRecips remoteRecips fwdHosts itemID action = do
    pure $ pure ()
{-
    moreRemoteRecips <- lift $ deliverLocal' True senderByKey senderByKey event localRecips
    checkFederation moreRemoteRecips
    remoteRecipsHttp <- lift $ deliverRemoteDB fwdHosts itemID remoteRecips moreRemoteRecips
    envelope <- lift $ do
        senderByHash <- hashLocalActor senderByKey
        prepareSendP senderActorID senderByHash itemID action
    return $ deliverRemoteHttp fwdHosts itemID envelope remoteRecipsHttp
    where
    checkFederation remoteRecips = do
        federation <- asksSite $ appFederation . appSettings
        unless (federation || null remoteRecips) $
            throwE "Federation disabled, but remote recipients found"
-}

forwardActivityDB
    :: (MonadSite m, SiteEnv m ~ App)
    => BL.ByteString
    -> RecipientRoutes
    -> ByteString
    -> ActorId
    -> LocalActorBy KeyHashid
    -> RecipientRoutes
    -> RemoteActivityId
    -> ReaderT SqlBackend m (Worker ())
forwardActivityDB body localRecips sig fwderActorID fwderByHash sieve activityID = do
    pure $ pure ()
{-
    let localRecipsFinal = localRecipSieve' sieve False False localRecips
        event = EventLocalFwdRemoteActivity fwderByKey activityID
    remoteRecips <-
        insertRemoteActivityToLocalInboxes False event localRecipsFinal
    remoteRecipsHttp <-
        forwardRemoteDB body activityID fwderActorID sig remoteRecips
    errand <- do
        fwderByHash <- hashLocalActor fwderByKey
        prepareForwardP fwderActorID fwderByHash body sig
    now <- liftIO getCurrentTime
    return $ forwardRemoteHttp now errand remoteRecipsHttp
-}