Unfinished updated outbox handler

config/models

@@ -48,6 +48,12 @@ OutboxItem
     activity  PersistActivity
     published UTCTime
 
+InboxItemLocal
+    person   PersonId
+    activity OutboxItemId
+
+    UniqueInboxItemLocal person activity
+
 VerifKey
     ident    LocalURI
     instance InstanceId

config/routes

@@ -138,5 +138,7 @@
 /s/#ShrIdent/p/#PrjIdent/t/#Int/deps/!new    TicketDepNewR         GET
 /s/#ShrIdent/p/#PrjIdent/t/#Int/deps/#Int    TicketDepR            POST DELETE
 /s/#ShrIdent/p/#PrjIdent/t/#Int/rdeps        TicketReverseDepsR    GET
+/s/#ShrIdent/p/#PrjIdent/t/#Int/participants TicketParticipantsR   GET
+/s/#ShrIdent/p/#PrjIdent/t/#Int/team         TicketTeamR           GET
 
 /s/#ShrIdent/p/#PrjIdent/w/+Texts            WikiPageR             GET

migrations/2019_04_11.model

@@ -0,0 +1,17 @@
+InboxItemLocal
+    person   PersonId
+    activity OutboxItemId
+
+    UniqueInboxItemLocal person activity
+
+Follow
+    person PersonId
+    target FollowerSetId
+
+    UniqueFollow person target
+
+RemoteFollow
+    actor  RemoteSharerId
+    target FollowerSetId
+
+    UniqueRemoteFollow actor target

src/Control/Concurrent/ResultShare.hs

@@ -0,0 +1,97 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2019 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/>.
+ -}
+
+-- | This module provides a structure that allows multiple threads that need to
+-- run the same action, to run it only once, and let all the threads get the
+-- result. For example, suppose in multiple places in your concurrent program,
+-- it needs to download some file over the network. Using 'ResultShare', the
+-- download is started when it's first requested, and if during the download
+-- other threads request it too, they instead wait for that existing download
+-- to complete and they all get that same file once it's downloaded.
+--
+-- Note that the result is deleted from the structure once the action
+-- completes! So if you'd like that downloaded file to be reused after the
+-- download completes, use some separate structure for that.
+--
+-- Limitations:
+--
+--   * The settings constructor is exposed, and there's no defaults, not
+--     allowing to add settings in a backward compatible way
+--   * It could be nice to provide defaults for plain IO and for UnliftIO
+--   * The action is constant, could make it more flexible
+module Control.Concurrent.ResultShare
+    ( ResultShareSettings (..)
+    , ResultShare ()
+    , newResultShare
+    , runShared
+    )
+where
+
+import Prelude
+
+import Control.Concurrent.MVar
+import Control.Concurrent.STM.TVar
+import Control.Monad
+import Control.Monad.IO.Class
+import Control.Monad.STM
+import Data.Hashable
+import Data.HashMap.Strict (HashMap)
+
+import qualified Data.HashMap.Strict as M
+
+data ResultShareSettings m k v a = ResultShareSettings
+    { resultShareFork   :: m () -> m ()
+    , resultShareAction :: k -> a -> m v
+    }
+
+data ResultShare m k v a = ResultShare
+    { _rsMap    :: TVar (HashMap k (MVar v))
+    , _rsFork   :: m () -> m ()
+    , _rsAction :: k -> a -> m v
+    }
+
+newResultShare
+    :: MonadIO m => ResultShareSettings m k v a -> m (ResultShare m k v a)
+newResultShare (ResultShareSettings fork action) = do
+    tvar <- liftIO $ newTVarIO M.empty
+    return $ ResultShare tvar fork action
+
+-- TODO this is copied from stm-2.5, remove when we upgrade LTS
+stateTVar :: TVar s -> (s -> (a, s)) -> STM a
+stateTVar var f = do
+    s <- readTVar var
+    let (a, s') = f s -- since we destructure this, we are strict in f
+    writeTVar var s'
+    return a
+
+runShared
+    :: (MonadIO m, Eq k, Hashable k) => ResultShare m k v a -> k -> a -> m v
+runShared (ResultShare tvar fork action) key param = do
+    (mvar, new) <- liftIO $ do
+        existing <- M.lookup key <$> readTVarIO tvar
+        case existing of
+            Just v -> return (v, False)
+            Nothing -> do
+                v <- newEmptyMVar
+                atomically $ stateTVar tvar $ \ m ->
+                    case M.lookup key m of
+                        Just v' -> ((v', False), m)
+                        Nothing -> ((v , True) , M.insert key v m)
+    when new $ fork $ do
+        result <- action key param
+        liftIO $ do
+            atomically $ modifyTVar' tvar $ M.delete key
+            putMVar mvar result
+    liftIO $ readMVar mvar

src/Data/List/Local.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2016, 2018 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2016, 2018, 2019 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -21,6 +21,7 @@ module Data.List.Local
     , groupMap
     , groupMapBy
     , groupMapBy1
+    , lookupSorted
     )
 where
 
@@ -97,3 +98,11 @@ groupMapBy1 eq f g = go
                 []  -> []
                 z:l -> toList $ go $ z :| l
         in  (f x, g x :| map g ys) :| rest
+
+lookupSorted :: Ord a => a -> [(a, b)] -> Maybe b
+lookupSorted _ []           = Nothing
+lookupSorted x ((y, z) : l) =
+    case compare x y of
+        LT -> lookupSorted x l
+        EQ -> Just z
+        GT -> Nothing

src/Data/List/NonEmpty/Local.hs

@@ -0,0 +1,60 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2019 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 Data.List.NonEmpty.Local
+    ( groupWithExtract
+    , groupWithExtractBy
+    , groupWithExtractBy1
+    , groupAllExtract
+    )
+where
+
+import Prelude
+
+import Data.Function
+import Data.List.NonEmpty (NonEmpty (..))
+
+import qualified Data.List.NonEmpty as NE
+
+extract :: (a -> b) -> (a -> c) -> NonEmpty a -> (b, NonEmpty c)
+extract f g (head :| tail) = (f head, g head :| map g tail)
+
+groupWithExtract
+    :: (Foldable f, Eq b)
+    => (a -> b)
+    -> (a -> c)
+    -> f a
+    -> [(b, NonEmpty c)]
+groupWithExtract f g = map (extract f g) . NE.groupWith f
+
+groupWithExtractBy
+    :: Foldable f
+    => (b -> b -> Bool)
+    -> (a -> b)
+    -> (a -> c)
+    -> f a
+    -> [(b, NonEmpty c)]
+groupWithExtractBy eq f g = map (extract f g) . NE.groupBy (eq `on` f)
+
+groupWithExtractBy1
+    :: (b -> b -> Bool)
+    -> (a -> b)
+    -> (a -> c)
+    -> NonEmpty a
+    -> NonEmpty (b, NonEmpty c)
+groupWithExtractBy1 eq f g = NE.map (extract f g) . NE.groupBy1 (eq `on` f)
+
+groupAllExtract :: Ord b => (a -> b) -> (a -> c) -> [a] -> [(b, NonEmpty c)]
+groupAllExtract f g = map (extract f g) . NE.groupAllWith f

src/Data/Maybe/Local.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2016, 2019 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -14,12 +14,19 @@
  -}
 
 module Data.Maybe.Local
-    ( partitionMaybePairs
+    ( partitionMaybes
+    , partitionMaybePairs
     )
 where
 
 import Prelude
 
+partitionMaybes :: [(Maybe a, b)] -> ([(a, b)], [b])
+partitionMaybes = foldr f ([], [])
+    where
+    f (Nothing, y) (ps, ys) = (ps         , y : ys)
+    f (Just x , y) (ps, ys) = ((x, y) : ps, ys)
+
 partitionMaybePairs :: [(Maybe a, Maybe b)] -> ([a], [b], [(a, b)])
 partitionMaybePairs = foldr f ([], [], [])
     where

src/Database/Persist/Local.hs

@@ -18,16 +18,22 @@ module Database.Persist.Local
     , getKeyBy
     , getValBy
     , insertUnique_
+    , insertBy'
     )
 where
 
 import Prelude
 
+import Control.Applicative
+import Control.Exception
 import Control.Monad
 import Control.Monad.IO.Class
+import Control.Monad.Trans.Maybe
 import Control.Monad.Trans.Reader
 import Database.Persist
 
+import qualified Data.Text as T
+
 idAndNew :: Either (Entity a) (Key a) -> (Key a, Bool)
 idAndNew (Left (Entity iid _)) = (iid, False)
 idAndNew (Right iid)           = (iid, True)
@@ -58,3 +64,21 @@ insertUnique_
     => record
     -> ReaderT backend m ()
 insertUnique_ = void . insertUnique
+
+insertBy'
+    :: ( MonadIO m
+       , PersistUniqueWrite backend
+       , PersistRecordBackend record backend
+       )
+    => record -> ReaderT backend m (Either (Entity record) (Key record))
+insertBy' val = do
+    let tryGet = Left <$> MaybeT (getByValue val)
+        tryWrite = Right <$> MaybeT (insertUnique val)
+    mresult <- runMaybeT $ tryGet <|> tryWrite <|> tryGet
+    case mresult of
+        Just result -> return result
+        Nothing ->
+            liftIO $ throwIO $ PersistError $
+                "insertBy': Couldn't insert but also couldn't get the value, \
+                \perhaps it was concurrently deleted or updated: " <>
+                T.pack (show $ map toPersistValue $ toPersistFields val)

src/Network/FedURI.hs

@@ -13,6 +13,8 @@
  - <http://creativecommons.org/publicdomain/zero/1.0/>.
  -}
 
+{-# LANGUAGE DeriveGeneric #-}
+
 module Network.FedURI
     ( FedURI (..)
     , parseFedURI
@@ -36,10 +38,12 @@ import Prelude
 import Control.Monad ((<=<))
 import Data.Aeson
 import Data.Bifunctor (bimap, first)
+import Data.Hashable
 import Data.Maybe (fromJust)
 import Data.Text (Text)
 import Database.Persist.Class (PersistField (..))
 import Database.Persist.Sql (PersistFieldSql (..))
+import GHC.Generics (Generic)
 import Network.URI
 
 import qualified Data.Text as T (pack, unpack, stripPrefix)
@@ -57,7 +61,9 @@ data FedURI = FedURI
     , furiPath     :: Text
     , furiFragment :: Text
     }
-    deriving Eq
+    deriving (Eq, Generic)
+
+instance Hashable FedURI
 
 instance FromJSON FedURI where
     parseJSON = withText "FedURI" $ either fail return . parseFedURI

src/Vervis/Federation.hs

@@ -22,28 +22,36 @@ where
 import Prelude
 
 import Control.Concurrent.STM.TVar
-import Control.Exception hiding (Handler)
+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 Data.Aeson (Object)
+import Data.Bifunctor
+import Data.Either
 import Data.Foldable
-import Data.List.NonEmpty (NonEmpty (..))
+import Data.Function
+import Data.List (sort, deleteBy, nub, union, unionBy)
+import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
 import Data.Maybe
+import Data.Semigroup
 import Data.Text (Text)
 import Data.Text.Encoding
 import Data.Time.Clock
 import Data.Traversable
-import Database.Persist
+import Data.Tuple
-import Database.Persist.Sql
+import Database.Persist hiding (deleteBy)
+import Database.Persist.Sql hiding (deleteBy)
 import Network.HTTP.Types.Header
 import Network.HTTP.Types.URI
+import UnliftIO.Exception (try)
 import Yesod.Core hiding (logError, logWarn, logInfo)
 import Yesod.Persist.Core
 
+import qualified Data.List.NonEmpty as NE
+import qualified Data.List.Ordered as LO
 import qualified Data.Text as T
-import qualified Data.Vector as V
 import qualified Database.Esqueleto as E
 
 import Network.HTTP.Signature
@@ -56,6 +64,8 @@ import Yesod.FedURI
 import Yesod.Hashids
 
 import Data.Either.Local
+import Data.List.Local
+import Data.List.NonEmpty.Local
 import Database.Persist.Local
 
 import Vervis.ActorKey
@@ -286,6 +296,7 @@ handleInboxActivity raw hActor iidActor rsidActor (Activity _id _luActor audienc
                     ]
             return (uNote, luContext)
 
+{-
 -- | 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'.
@@ -297,6 +308,7 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished c
     uContext <- fromMaybeE muContext "Note without context"
     uRecip <- parseAudience aud "Note has not-just-single-to audience"
     recipContextParent <- parseRecipContextParent uRecip uContext muParent
+
     (lmid, mdeliver) <- ExceptT $ runDB $ runExceptT $ do
         (pid, shrUser) <- verifyIsLoggedInUser luAttrib "Note attributed to different actor"
         case recipContextParent of
@@ -606,3 +618,556 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished c
             doc = activity luAct
         update obid [OutboxItemActivity =. PersistJSON doc]
         return (lmid, doc)
+-}
+
+data LocalTicketRecipient = LocalTicketParticipants | LocalTicketTeam
+    deriving (Eq, Ord)
+
+data LocalProjectRecipient
+    = LocalProject
+    | LocalTicketRelated Int LocalTicketRecipient
+    deriving (Eq, Ord)
+
+data LocalSharerRecipient
+    = LocalSharer
+    | LocalProjectRelated PrjIdent LocalProjectRecipient
+    deriving (Eq, Ord)
+
+data LocalRecipient = LocalSharerRelated ShrIdent LocalSharerRecipient
+    deriving (Eq, Ord)
+
+data LocalTicketRelatedSet
+    = OnlyTicketParticipants
+    | OnlyTicketTeam
+    | BothTicketParticipantsAndTeam
+
+data LocalProjectRelatedSet = LocalProjectRelatedSet
+    { localRecipProject       :: Bool
+    , localRecipTicketRelated :: [(Int, LocalTicketRelatedSet)]
+    }
+
+data LocalSharerRelatedSet = LocalSharerRelatedSet
+    { localRecipSharer         :: Bool
+    , localRecipProjectRelated :: [(PrjIdent, LocalProjectRelatedSet)]
+    }
+
+type LocalRecipientSet = [(ShrIdent, LocalSharerRelatedSet)]
+
+newtype FedError = FedError Text deriving Show
+
+instance Exception FedError
+
+-- | 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'.
+handleOutboxNote :: Text -> Note -> Handler (Either Text LocalMessageId)
+handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished content) = runExceptT $ do
+    verifyHostLocal host "Attributed to non-local actor"
+    verifyNothing mluNote "Note specifies an id"
+    verifyNothing mpublished "Note specifies published"
+    uContext <- fromMaybeE muContext "Note without context"
+    recips <- nonEmptyE (concatRecipients aud) "Note without recipients"
+    (mparent, localRecips, mticket, remoteRecips) <- parseRecipsContextParent recips uContext muParent
+    result <- lift $ try $ runDB $ (either abort return =<<) . runExceptT $ do
+        (pid, shrUser) <- verifyIsLoggedInUser luAttrib "Note attributed to different actor"
+        (did, meparent, mcollections) <- case mticket of
+            Just (shr, prj, num) -> do
+                mt <- lift $ runMaybeT $ do
+                    sid <- MaybeT $ getKeyBy $ UniqueSharer shr
+                    jid <- MaybeT $ getKeyBy $ UniqueProject prj sid
+                    t <- MaybeT $ getValBy $ UniqueTicket jid num
+                    return (sid, t)
+                (sid, t) <- fromMaybeE mt "Context: No such local ticket"
+                let did = ticketDiscuss t
+                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
+                return (did, Left <$> mmidParent, Just (sid, ticketFollowers t))
+            Nothing -> do
+                (rd, rdnew) <- do
+                    let (hContext, luContext) = f2l uContext
+                    miid <- lift $ getKeyBy $ UniqueInstance hContext
+                    mrd <-
+                        case miid of
+                            Just iid -> lift $ getValBy $ UniqueRemoteDiscussionIdent iid luContext
+                            Nothing -> return Nothing
+                    case mrd of
+                        Just rd -> return (rd, False)
+                        Nothing -> lift $ withHostLock hContext $ do
+                            (iid, inew) <-
+                                case miid of
+                                    Just i -> return (i, False)
+                                    Nothing -> idAndNew <$> insertBy (Instance hContext)
+                            if inew
+                                then do
+                                    did <- insert Discussion
+                                    rd <- insertRecord $ RemoteDiscussion iid luContext did
+                                    return (rd, True)
+                                else do
+                                    mrd <- getValBy $ UniqueRemoteDiscussionIdent iid luContext
+                                    case mrd of
+                                        Just rd -> return (rd, False)
+                                        Nothing -> do
+                                            did <- insert Discussion
+                                            rd <- insertRecord $ RemoteDiscussion iid luContext did
+                                            return (rd, True)
+                let did = remoteDiscussionDiscuss rd
+                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
+                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)
+    (lmid, doc, moreRemotes) <- case result of
+        Left (FedError t) -> throwE t
+        Right r -> return r
+    -- TODO deliver *async* to remote sharers: remoteRecips and moreRemotes
+    --
+    -- doc          :: Doc Activity
+    -- remoteRecips :: [FedURI]
+    -- moreRemotes  :: [((InstanceId, Text), NonEmpty (RemoteSharerId, LocalURI))]
+    return lmid
+    where
+    verifyNothing :: Monad m => Maybe a -> e -> ExceptT e m ()
+    verifyNothing Nothing  _ = return ()
+    verifyNothing (Just _) e = throwE e
+
+    concatRecipients :: Audience -> [FedURI]
+    concatRecipients (Audience to bto cc bcc gen) = concat [to, bto, cc, bcc, gen]
+
+    nonEmptyE :: Monad m => [a] -> e -> ExceptT e m (NonEmpty a)
+    nonEmptyE l e =
+        case nonEmpty l of
+            Nothing -> throwE e
+            Just ne -> return ne
+
+    parseRecipsContextParent
+        :: NonEmpty FedURI
+        -> FedURI
+        -> Maybe FedURI
+        -> ExceptT Text Handler
+            ( Maybe (Either (ShrIdent, LocalMessageId) (Text, LocalURI))
+            , [ShrIdent]
+            , Maybe (ShrIdent, PrjIdent, Int)
+            , [FedURI]
+            )
+    parseRecipsContextParent recips uContext muParent = do
+        (locals, remotes) <- lift $ splitRecipients recips
+        let (localsParsed, localsRest) = parseLocalRecipients locals
+        unless (null localsRest) $
+            throwE "Note has invalid local recipients"
+        let localsSet = groupLocalRecipients localsParsed
+            (hContext, luContext) = f2l uContext
+        parent <- parseParent uContext muParent
+        local <- hostIsLocal hContext
+        if local
+            then do
+                ticket <- parseContextTicket luContext
+                shrs <- verifyTicketRecipients ticket localsSet
+                return (parent, shrs, Just ticket, remotes)
+            else do
+                shrs <- verifyOnlySharers localsSet
+                return (parent, shrs, Nothing, remotes)
+        where
+        -- First step: Split into remote and local:
+        splitRecipients :: NonEmpty FedURI -> Handler ([LocalURI], [FedURI])
+        splitRecipients recips = do
+            home <- getsYesod $ appInstanceHost . appSettings
+            let (local, remote) = NE.partition ((== home) . furiHost) recips
+            return (map (snd . f2l) local, remote)
+
+        -- Parse the local recipients
+        parseLocalRecipients :: [LocalURI] -> ([LocalRecipient], [Either LocalURI (Route App)])
+        parseLocalRecipients = swap . partitionEithers . map decide
+            where
+            parseLocalRecipient (SharerR shr) = Just $ LocalSharerRelated shr LocalSharer
+            parseLocalRecipient (ProjectR shr prj) =
+                Just $ LocalSharerRelated shr $ LocalProjectRelated prj LocalProject
+            parseLocalRecipient (TicketParticipantsR shr prj num) =
+                Just $ LocalSharerRelated shr $ LocalProjectRelated prj $ LocalTicketRelated num LocalTicketParticipants
+            parseLocalRecipient (TicketTeamR shr prj num) =
+                Just $ LocalSharerRelated shr $ LocalProjectRelated prj $ LocalTicketRelated num LocalTicketTeam
+            parseLocalRecipient _ = Nothing
+            decide lu =
+                case decodeRouteLocal lu of
+                    Nothing -> Left $ Left lu
+                    Just route ->
+                        case parseLocalRecipient route of
+                            Nothing -> Left $ Right route
+                            Just lr -> Right lr
+
+        -- Group local recipients
+        groupLocalRecipients :: [LocalRecipient] -> LocalRecipientSet
+        groupLocalRecipients
+            = map
+                ( second
+                    $ uncurry LocalSharerRelatedSet
+                    . bimap
+                        (not . null)
+                        ( map
+                            ( second
+                                $ uncurry LocalProjectRelatedSet
+                                . bimap
+                                    (not . null)
+                                    ( map (second ltrs2ltrs)
+                                    . groupWithExtract fst snd
+                                    )
+                                . partitionEithers
+                                . NE.toList
+                            )
+                        . groupWithExtract fst (lpr2e . snd)
+                        )
+                    . partitionEithers
+                    . NE.toList
+                )
+            . groupWithExtract
+                (\ (LocalSharerRelated shr _) -> shr)
+                (\ (LocalSharerRelated _ lsr) -> lsr2e lsr)
+            . sort
+            where
+            lsr2e LocalSharer                   = Left ()
+            lsr2e (LocalProjectRelated prj lpr) = Right (prj, lpr)
+            lpr2e LocalProject                 = Left ()
+            lpr2e (LocalTicketRelated num ltr) = Right (num, ltr)
+            ltrs2ltrs (LocalTicketParticipants :| l) =
+                if LocalTicketTeam `elem` l
+                    then BothTicketParticipantsAndTeam
+                    else OnlyTicketParticipants
+            ltrs2ltrs (LocalTicketTeam :| l) =
+                if LocalTicketParticipants `elem` l
+                    then BothTicketParticipantsAndTeam
+                    else OnlyTicketTeam
+
+        parseParent :: FedURI -> Maybe FedURI -> ExceptT Text Handler (Maybe (Either (ShrIdent, LocalMessageId) (Text, LocalURI)))
+        parseParent _        Nothing        = return Nothing
+        parseParent uContext (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)
+
+        parseContextTicket :: Monad m => LocalURI -> ExceptT Text m (ShrIdent, PrjIdent, Int)
+        parseContextTicket luContext = do
+            route <- case decodeRouteLocal luContext of
+                Nothing -> throwE "Local context isn't a valid route"
+                Just r -> return r
+            case route of
+                TicketR shr prj num -> return (shr, prj, num)
+                _ -> throwE "Local context isn't a ticket route"
+
+        atMostSharer :: e -> (ShrIdent, LocalSharerRelatedSet) -> ExceptT e Handler (Maybe ShrIdent)
+        atMostSharer _ (shr, LocalSharerRelatedSet s []) = return $ if s then Just shr else Nothing
+        atMostSharer e (_  , LocalSharerRelatedSet _ _ ) = throwE e
+
+        verifyTicketRecipients :: (ShrIdent, PrjIdent, Int) -> LocalRecipientSet -> ExceptT Text Handler [ShrIdent]
+        verifyTicketRecipients (shr, prj, num) recips = do
+            lsrSet <- fromMaybeE (lookupSorted shr recips) "Note with local context: No required recipients"
+            (prj', lprSet) <- verifySingleton (localRecipProjectRelated lsrSet) "Note project-related recipient sets"
+            unless (prj == prj') $ throwE "Note project recipients mismatch context's project"
+            unless (localRecipProject lprSet) $ throwE "Note context's project not addressed"
+            (num', ltrSet) <- verifySingleton (localRecipTicketRelated lprSet) "Note ticket-related recipient sets"
+            unless (num == num') $ throwE "Note project recipients mismatch context's ticket number"
+            case ltrSet of
+                OnlyTicketParticipants -> throwE "Note ticket participants not addressed"
+                OnlyTicketTeam -> throwE "Note ticket team not addressed"
+                BothTicketParticipantsAndTeam -> return ()
+            let rest = deleteBy ((==) `on` fst) (shr, lsrSet) recips
+                orig = if localRecipSharer lsrSet then Just shr else Nothing
+            catMaybes . (orig :) <$> traverse (atMostSharer "Note with unrelated non-sharer recipients") rest
+                where
+                verifySingleton :: Monad m => [a] -> Text -> ExceptT Text m a
+                verifySingleton []  t = throwE $ t <> ": expected 1, got 0"
+                verifySingleton [x] _ = return x
+                verifySingleton l   t = throwE $ t <> ": expected 1, got " <> T.pack (show $ length l)
+
+        verifyOnlySharers :: LocalRecipientSet -> ExceptT Text Handler [ShrIdent]
+        verifyOnlySharers lrs = catMaybes <$> traverse (atMostSharer "Note with remote context but local project-related recipients") lrs
+
+    abort :: Text -> AppDB a
+    abort = liftIO . throwIO . FedError
+
+    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
+
+    insertMessage
+        :: LocalURI
+        -> ShrIdent
+        -> PersonId
+        -> FedURI
+        -> DiscussionId
+        -> Maybe FedURI
+        -> Maybe (Either MessageId FedURI)
+        -> Text
+        -> AppDB (LocalMessageId, OutboxItemId, 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, obid, doc)
+
+    -- | Merge 2 lists ordered on fst, concatenating snd values when
+    -- multiple identical fsts occur. The resulting list is ordered on fst,
+    -- and each fst value appears only once.
+    --
+    -- >>> mergeWith (+) [('a',3), ('a',1), ('b',5)] [('a',2), ('c',4)]
+    -- [('a',6), ('b',5), ('c',4)]
+    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
+
+    -- 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.
+    deliverLocal
+        :: OutboxItemId
+        -> [ShrIdent]
+        -> Maybe (SharerId, FollowerSetId)
+        -> ExceptT Text AppDB [((InstanceId, Text), NonEmpty (RemoteSharerId, LocalURI))]
+    deliverLocal obid recips mticket = do
+        recipPids <- traverse getPersonId $ nub recips
+        (morePids, remotes) <-
+            lift $ case mticket of
+                Nothing -> return ([], [])
+                Just (sid, fsid) -> do
+                    (teamPids, teamRemotes) <- getTicketTeam sid
+                    (fsPids, fsRemotes) <- getFollowers fsid
+                    return
+                        ( union teamPids fsPids
+                          -- TODO this is inefficient! The way this combines
+                          -- same-host sharer lists is:
+                          --
+                          --   (1) concatenate them
+                          --   (2) nubBy fst to remove duplicates
+                          --
+                          -- But we have knowledge that:
+                          --
+                          --   (1) in each of the 2 lists we're combining, each
+                          --       instance occurs only once
+                          --   (2) in each actor list, each actor occurs only
+                          --       once
+                          --
+                          -- So we can improve this code by:
+                          --
+                          --   (1) Not assume arbitrary number of consecutive
+                          --       repetition of the same instance, we may only
+                          --       have repetition if the same instance occurs
+                          --       in both lists
+                          --   (2) Don't <> the lists, instead apply unionBy or
+                          --       something better (unionBy assumes one list
+                          --       may have repetition, but removes repetition
+                          --       from the other; we know both lists have no
+                          --       repetition, can we use that to do this
+                          --       faster than unionBy?)
+                          --
+                          -- Also, if we ask the DB to sort by actor, then in
+                          -- the (2) point above, instead of unionBy we can use
+                          -- the knowledge the lists are sorted, and apply
+                          -- LO.unionBy instead. Or even better, because
+                          -- LO.unionBy doesn't assume no repetitions (possibly
+                          -- though it still does it the fastest way).
+                          --
+                          -- So, in mergeConcat, don't start with merging,
+                          -- because we lose the knowledge that each list's
+                          -- 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
+                        )
+        lift $ for_ (union recipPids morePids) $ \ pid -> insert_ $ InboxItemLocal pid obid
+        return remotes
+        where
+        getPersonOrGroupId :: SharerId -> AppDB (Either PersonId GroupId)
+        getPersonOrGroupId sid = do
+            mpid <- getKeyBy $ UniquePersonIdent sid
+            mgid <- getKeyBy $ UniqueGroup sid
+            requireEitherM mpid mgid
+                "Found sharer that is neither person nor group"
+                "Found sharer that is both person and group"
+        getPersonId :: ShrIdent -> ExceptT Text AppDB PersonId
+        getPersonId shr = do
+            msid <- lift $ getKeyBy $ UniqueSharer shr
+            sid <- fromMaybeE msid "Local Note addresses nonexistent local sharer"
+            id_ <- lift $ getPersonOrGroupId sid
+            case id_ of
+                Left pid -> return pid
+                Right _gid -> throwE "Local Note addresses a local group"
+        groupRemotes :: [(InstanceId, Text, RemoteSharerId, LocalURI)] -> [((InstanceId, Text), NonEmpty (RemoteSharerId, LocalURI))]
+        groupRemotes = groupWithExtractBy ((==) `on` fst) fst snd . map toPairs
+            where
+            toPairs (iid, h, rsid, lu) = ((iid, h), (rsid, lu))
+        getTicketTeam :: SharerId -> AppDB ([PersonId], [((InstanceId, Text), NonEmpty (RemoteSharerId, LocalURI))])
+        getTicketTeam sid = do
+            id_ <- getPersonOrGroupId sid
+            (,[]) <$> case id_ of
+                Left pid -> return [pid]
+                Right gid ->
+                    map (groupMemberPerson . entityVal) <$>
+                        selectList [GroupMemberGroup ==. gid] []
+        getFollowers :: FollowerSetId -> AppDB ([PersonId], [((InstanceId, Text), NonEmpty (RemoteSharerId, LocalURI))])
+        getFollowers fsid = do
+            local <- selectList [FollowTarget ==. fsid] []
+            remote <- E.select $ E.from $ \ (rf `E.InnerJoin` rs `E.InnerJoin` i) -> do
+                E.on $ rs E.^. RemoteSharerInstance E.==. i E.^. InstanceId
+                E.on $ rf E.^. RemoteFollowActor E.==. rs E.^. RemoteSharerId
+                E.where_ $ rf E.^. RemoteFollowTarget E.==. E.val fsid
+                E.orderBy [E.asc $ i E.^. InstanceId]
+                return
+                    ( i E.^. InstanceId
+                    , i E.^. InstanceHost
+                    , rs E.^. RemoteSharerId
+                    , rs E.^. RemoteSharerInbox
+                    )
+            return
+                ( map (followPerson . entityVal) local
+                , groupRemotes $
+                    map (\ (E.Value iid, E.Value h, E.Value rsid, E.Value luInbox) ->
+                            (iid, h, rsid, luInbox)
+                        )
+                        remote
+                )
+
+    -- Deliver to a local sharer, if they exist as a user account
+    deliverToLocalSharer :: OutboxItemId -> ShrIdent -> ExceptT Text AppDB ()
+    deliverToLocalSharer obid shr = do
+        msid <- lift $ getKeyBy $ UniqueSharer shr
+        sid <- fromMaybeE msid "Local Note addresses nonexistent local sharer"
+        mpid <- lift $ getKeyBy $ UniquePersonIdent sid
+        mgid <- lift $ getKeyBy $ UniqueGroup sid
+        id_ <-
+            requireEitherM mpid mgid
+                "Found sharer that is neither person nor group"
+                "Found sharer that is both person and group"
+        case id_ of
+            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,
+    -- 'allKnown' and 'stillUnknown'. We could be done with DB and proceed to
+    -- launch HTTP requests, but we haven't considered something: Some actors
+    -- are known to be unreachable:
+    --
+    --   (1) There are actors we've never reached, for whom there are pending
+    --       deliveries
+    --   (2) There are actors we already fetched, but for whom there are
+    --       pending deliveries because lately their inboxes are unreachable
+    --
+    -- 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 RemoteSharer, 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 (RemoteSharerId, 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'))
+                else do
+                    es <- for lus' $ \ lu -> do
+                        mers <- getBy $ UniqueRemoteSharer iid lu
+                        return $
+                            case mers of
+                                Just (Entity rsid rs) -> Left (rsid, remoteSharerInbox rs)
+                                Nothing -> Right lu
+                    let (newKnown, unknown) = partitionEithers $ NE.toList es
+                    return ((iid, h), (nonEmpty newKnown, nonEmpty unknown))
+        let moreKnown = mapMaybe (\ (i, (k, _)) -> (i,) <$> k) recips'
+            stillUnknown = mapMaybe (\ (i, (_, u)) -> (i,) <$> u) recips'
+            -- ^ [ ( (iid, h) , NonEmpty luActor ) ]
+            -- TODO see the earlier TODO about merge, it applies here too
+            allKnown = map (second $ NE.nubBy ((==) `on` fst)) $ mergeConcat known moreKnown
+            -- ^ [ ( (iid, h) , NonEmpty (rsid, inb) ) ]
+        error "TODO CONTINUE"
+        where
+        groupByHost :: [FedURI] -> [(Text, NonEmpty LocalURI)]
+        groupByHost = groupAllExtract furiHost (snd . f2l)

src/Vervis/Handler/Ticket.hs

@@ -48,6 +48,8 @@ module Vervis.Handler.Ticket
     , postTicketDepR
     , deleteTicketDepR
     , getTicketReverseDepsR
+    , getTicketParticipantsR
+    , getTicketTeamR
     )
 where
 
@@ -767,3 +769,9 @@ deleteTicketDepR shr prj pnum cnum = do
 
 getTicketReverseDepsR :: ShrIdent -> PrjIdent -> Int -> Handler Html
 getTicketReverseDepsR = getTicketDeps False
+
+getTicketParticipantsR :: ShrIdent -> PrjIdent -> Int -> Handler TypedContent
+getTicketParticipantsR = error "TODO implement getTicketParticipantsR"
+
+getTicketTeamR :: ShrIdent -> PrjIdent -> Int -> Handler TypedContent
+getTicketTeamR = error "TODO implement getTicketTeamR"

src/Vervis/Migration.hs

@@ -237,6 +237,8 @@ changes =
         "LocalMessage"
         (Nothing :: Maybe Text)
         "unlinkedParent"
+      -- 55
+    , addEntities model_2019_04_11
     ]
 
 migrateDB :: MonadIO m => ReaderT SqlBackend m (Either Text (Int, Int))

src/Vervis/Migration/Model.hs

@@ -36,6 +36,7 @@ module Vervis.Migration.Model
     , FollowerSet2019Generic (..)
     , FollowerSet2019
     , Ticket2019
+    , model_2019_04_11
     )
 where
 
@@ -91,3 +92,6 @@ model_2019_03_30 = $(schema "2019_03_30")
 
 makeEntitiesMigration "2019"
     $(modelFile "migrations/2019_03_30_follower_set.model")
+
+model_2019_04_11 :: [Entity SqlBackend]
+model_2019_04_11 = $(schema "2019_04_11")

src/Vervis/Model/Ident.hs

@@ -61,7 +61,7 @@ import Web.PathPieces.Local ()
 
 newtype ShrIdent = ShrIdent { unShrIdent :: CI Text }
     deriving
-        (Eq, Show, Read, PersistField, PersistFieldSql, SqlString, PathPiece)
+        (Eq, Ord, Show, Read, PersistField, PersistFieldSql, SqlString, PathPiece)
 
 shr2text :: ShrIdent -> Text
 shr2text = CI.original . unShrIdent
@@ -71,7 +71,7 @@ text2shr = ShrIdent . CI.mk
 
 newtype KyIdent = KyIdent { unKyIdent :: CI Text }
     deriving
-        (Eq, Show, Read, PersistField, PersistFieldSql, SqlString, PathPiece)
+        (Eq, Ord, Show, Read, PersistField, PersistFieldSql, SqlString, PathPiece)
 
 ky2text :: KyIdent -> Text
 ky2text = CI.original . unKyIdent
@@ -81,7 +81,7 @@ text2ky = KyIdent . CI.mk
 
 newtype RlIdent = RlIdent { unRlIdent :: CI Text }
     deriving
-        (Eq, Show, Read, PersistField, PersistFieldSql, SqlString, PathPiece)
+        (Eq, Ord, Show, Read, PersistField, PersistFieldSql, SqlString, PathPiece)
 
 rl2text :: RlIdent -> Text
 rl2text = CI.original . unRlIdent
@@ -91,7 +91,7 @@ text2rl = RlIdent . CI.mk
 
 newtype PrjIdent = PrjIdent { unPrjIdent :: CI Text }
     deriving
-        (Eq, Show, Read, PersistField, PersistFieldSql, SqlString, PathPiece)
+        (Eq, Ord, Show, Read, PersistField, PersistFieldSql, SqlString, PathPiece)
 
 prj2text :: PrjIdent -> Text
 prj2text = CI.original . unPrjIdent
@@ -101,7 +101,7 @@ text2prj = PrjIdent . CI.mk
 
 newtype RpIdent = RpIdent { unRpIdent :: CI Text }
     deriving
-        (Eq, Show, Read, PersistField, PersistFieldSql, SqlString, PathPiece)
+        (Eq, Ord, Show, Read, PersistField, PersistFieldSql, SqlString, PathPiece)
 
 rp2text :: RpIdent -> Text
 rp2text = CI.original . unRpIdent
@@ -111,7 +111,7 @@ text2rp = RpIdent . CI.mk
 
 newtype WflIdent = WflIdent { unWflIdent :: CI Text }
     deriving
-        (Eq, Show, Read, PersistField, PersistFieldSql, SqlString, PathPiece)
+        (Eq, Ord, Show, Read, PersistField, PersistFieldSql, SqlString, PathPiece)
 
 wfl2text :: WflIdent -> Text
 wfl2text = CI.original . unWflIdent
@@ -121,7 +121,7 @@ text2wfl = WflIdent . CI.mk
 
 newtype FldIdent = FldIdent { unFldIdent :: CI Text }
     deriving
-        (Eq, Show, Read, PersistField, PersistFieldSql, SqlString, PathPiece)
+        (Eq, Ord, Show, Read, PersistField, PersistFieldSql, SqlString, PathPiece)
 
 fld2text :: FldIdent -> Text
 fld2text = CI.original . unFldIdent
@@ -131,7 +131,7 @@ text2fld = FldIdent . CI.mk
 
 newtype EnmIdent = EnmIdent { unEnmIdent :: CI Text }
     deriving
-        (Eq, Show, Read, PersistField, PersistFieldSql, SqlString, PathPiece)
+        (Eq, Ord, Show, Read, PersistField, PersistFieldSql, SqlString, PathPiece)
 
 enm2text :: EnmIdent -> Text
 enm2text = CI.original . unEnmIdent

src/Vervis/RemoteActorStore.hs

@@ -29,8 +29,11 @@ where
 import Prelude
 
 import Control.Concurrent.MVar (MVar, newMVar)
+import Control.Concurrent.ResultShare
 import Control.Concurrent.STM.TVar
+import Control.Exception
 import Control.Monad
+import Control.Monad.Logger.CallStack
 import Control.Monad.STM
 import Control.Monad.Trans.Except
 import Data.Foldable
@@ -43,10 +46,11 @@ import Database.Persist
 import Database.Persist.Sql
 import Network.HTTP.Client
 import UnliftIO.MVar (withMVar)
-import Yesod.Core
+import Yesod.Core hiding (logError)
 import Yesod.Persist.Core
 
 import qualified Data.HashMap.Strict as M
+import qualified Data.Text as T
 
 import Crypto.PublicVerifKey
 import Database.Persist.Local
@@ -74,6 +78,8 @@ class Yesod site => YesodRemoteActorStore site where
     siteActorRoomMode    :: site -> Maybe Int
     siteRejectOnMaxKeys  :: site -> Bool
 
+    siteActorFetchShare  :: site -> ResultShare (HandlerFor site) FedURI (Either String (Entity RemoteSharer)) InstanceId
+
 -- TODO this is copied from stm-2.5, remove when we upgrade LTS
 stateTVar :: TVar s -> (s -> (a, s)) -> STM a
 stateTVar var f = do
@@ -438,3 +444,40 @@ addVerifKey h uinb vkd =
                             else when (inew == Just False) $ lift $ makeActorRoomForPersonalKey limit rsid
                 lift $ insert_ $ VerifKey luKey iid mexpires key (Just rsid)
         return (iid, rsid)
+
+actorFetchShareSettings
+    :: ( YesodPersist site
+       , PersistUniqueRead (YesodPersistBackend site)
+       , PersistStoreWrite (YesodPersistBackend site)
+       , BaseBackend (YesodPersistBackend site) ~ SqlBackend
+       , HasHttpManager site
+       )
+    => ResultShareSettings (HandlerFor site) FedURI (Either String (Entity RemoteSharer)) InstanceId
+actorFetchShareSettings = ResultShareSettings
+    { resultShareFork   = forkHandler $ \ e -> logError $ "ActorFetchShare action failed! " <> T.pack (displayException e)
+    , resultShareAction = \ u iid -> do
+        let (h, lu) = f2l u
+        mers <- runDB $ getBy $ UniqueRemoteSharer iid lu
+        case mers of
+            Just ers -> return $ Right ers
+            Nothing -> do
+                manager <- getsYesod getHttpManager
+                eactor <- fetchAPID manager actorId h lu
+                for eactor $ \ actor -> runDB $
+                    insertEntity $ RemoteSharer lu iid (actorInbox actor)
+    }
+
+fetchRemoteActor
+    :: ( YesodPersist site
+       , PersistUniqueRead (YesodPersistBackend site)
+       , BaseBackend (YesodPersistBackend site) ~ SqlBackend
+       , YesodRemoteActorStore site
+       )
+    => InstanceId -> Text -> LocalURI -> HandlerFor site (Either String (Entity RemoteSharer))
+fetchRemoteActor iid host luActor = do
+    mers <- runDB $ getBy $ UniqueRemoteSharer iid luActor
+    case mers of
+        Just ers -> return $ Right ers
+        Nothing -> do
+            afs <- getsYesod siteActorFetchShare
+            runShared afs (l2f host luActor) iid

vervis.cabal

@@ -40,6 +40,7 @@ flag library-only
 library
   exposed-modules:     Control.Applicative.Local
                        Control.Concurrent.Local
+                       Control.Concurrent.ResultShare
                        Crypto.PubKey.Encoding
                        Crypto.PublicVerifKey
                        Darcs.Local.Repository
@@ -65,6 +66,7 @@ library
                        Data.Int.Local
                        Data.KeyFile
                        Data.List.Local
+                       Data.List.NonEmpty.Local
                        Data.Maybe.Local
                        Data.Paginate.Local
                        Data.Text.UTF8.Local
@@ -252,6 +254,7 @@ library
                      , data-default
                      , data-default-class
                      , data-default-instances-bytestring
+                     , data-ordlist
                        -- for drawing DAGs: RBAC role inheritance, etc.
                        , diagrams-core
                        , diagrams-lib