New module structure for ActivityPub C2S and S2S code

src/Control/Monad/Trans/Except/Local.hs

@@ -0,0 +1,27 @@
+{- 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 Control.Monad.Trans.Except.Local
+    ( fromMaybeE
+    )
+where
+
+import Prelude
+
+import Control.Monad.Trans.Except
+
+fromMaybeE :: Monad m => Maybe a -> e -> ExceptT e m a
+fromMaybeE Nothing  t = throwE t
+fromMaybeE (Just x) _ = return x

src/Data/Either/Local.hs

@@ -17,6 +17,7 @@ module Data.Either.Local
     ( maybeRight
     , maybeLeft
     , requireEither
+    , requireEitherM
     , requireEitherAlt
     )
 where
@@ -24,6 +25,8 @@ where
 import Prelude
 
 import Control.Applicative
+import Control.Exception
+import Control.Monad.IO.Class
 
 maybeRight :: Either a b -> Maybe b
 maybeRight (Left _)  = Nothing
@@ -39,6 +42,13 @@ requireEither (Just _) (Just _)  = Left True
 requireEither (Just x) Nothing   = Right $ Left x
 requireEither Nothing  (Just y)  = Right $ Right y
 
+requireEitherM
+    :: MonadIO m => Maybe a -> Maybe b -> String -> String -> m (Either a b)
+requireEitherM mx my f t =
+    case requireEither mx my of
+        Left b    -> liftIO $ throwIO $ userError $ if b then t else f
+        Right exy -> return exy
+
 requireEitherAlt
     :: Applicative f
     => f (Maybe a) -> f (Maybe b) -> String -> String -> f (Either a b)

src/Data/Tuple/Local.hs

@@ -0,0 +1,36 @@
+{- 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.Tuple.Local
+    ( fst3
+    , fst4
+    , thd3
+    , fourth4
+    )
+where
+
+import Prelude
+
+fst3 :: (a, b, c) -> a
+fst3 (x, _, _) = x
+
+fst4 :: (a, b, c, d) -> a
+fst4 (x, _, _, _) = x
+
+thd3 :: (a, b, c) -> c
+thd3 (_, _, z) = z
+
+fourth4 :: (a, b, c, d) -> d
+fourth4 (_, _, _, w) = w

src/Vervis/API.hs

@@ -0,0 +1,809 @@
+{- 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 Vervis.API
+    ( createNoteC
+    , getFollowersCollection
+    )
+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 Crypto.Hash
+import Data.Aeson
+import Data.Bifunctor
+import Data.ByteString (ByteString)
+import Data.Either
+import Data.Foldable
+import Data.Function
+import Data.List (sort, deleteBy, nub, union, unionBy, partition)
+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.Time.Units
+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 hiding (SHA256)
+import UnliftIO.Exception (try)
+import Yesod.Core hiding (logError, logWarn, logInfo, logDebug)
+import Yesod.Persist.Core
+
+import qualified Data.ByteString.Lazy as BL
+import qualified Data.CaseInsensitive as CI
+import qualified Data.List as L
+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 qualified Network.Wai as W
+
+import Data.Time.Interval
+import Network.HTTP.Signature hiding (requestHeaders)
+import Yesod.HttpSignature
+
+import Crypto.PublicVerifKey
+import Database.Persist.JSON
+import Network.FedURI
+import Network.HTTP.Digest
+import Web.ActivityPub hiding (Follow)
+import Yesod.ActivityPub
+import Yesod.Auth.Unverified
+import Yesod.FedURI
+import Yesod.Hashids
+import Yesod.MonadSite
+
+import Control.Monad.Trans.Except.Local
+import Data.Aeson.Local
+import Data.Either.Local
+import Data.List.Local
+import Data.List.NonEmpty.Local
+import Data.Maybe.Local
+import Data.Tuple.Local
+import Database.Persist.Local
+import Yesod.Persist.Local
+
+import Vervis.ActivityPub
+import Vervis.ActorKey
+import Vervis.Foundation
+import Vervis.Model
+import Vervis.Model.Ident
+import Vervis.RemoteActorStore
+import Vervis.Settings
+
+data Recip
+    = RecipRA (Entity RemoteActor)
+    | RecipURA (Entity UnfetchedRemoteActor)
+    | RecipRC (Entity RemoteCollection)
+
+data LocalTicketRecipient = LocalTicketParticipants | LocalTicketTeam
+    deriving (Eq, Ord)
+
+data LocalProjectRecipient
+    = LocalProject
+    | LocalProjectFollowers
+    | 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
+    , localRecipProjectFollowers :: Bool
+    , localRecipTicketRelated    :: [(Int, LocalTicketRelatedSet)]
+    }
+
+data LocalSharerRelatedSet = LocalSharerRelatedSet
+    { localRecipSharer         :: Bool
+    , localRecipProjectRelated :: [(PrjIdent, LocalProjectRelatedSet)]
+    }
+
+type LocalRecipientSet = [(ShrIdent, LocalSharerRelatedSet)]
+
+parseComment :: LocalURI -> ExceptT Text Handler (ShrIdent, LocalMessageId)
+parseComment luParent = do
+    route <- case decodeRouteLocal luParent of
+        Nothing -> throwE "Not a local route"
+        Just r -> return r
+    case route of
+        MessageR shr hid -> (shr,) <$> decodeKeyHashidE hid "Non-existent local message hashid"
+        _                -> throwE "Not a local message route"
+
+-- | 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'.
+createNoteC :: Text -> Note -> Handler (Either Text LocalMessageId)
+createNoteC host (Note mluNote luAttrib aud muParent muContext mpublished source 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
+    federation <- getsYesod $ appFederation . appSettings
+    unless (federation || null remoteRecips) $
+        throwE "Federation disabled, but remote recipients specified"
+    (lmid, obid, doc, remotesHttp) <- runDBExcept $ 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
+                    Entity jid j <- MaybeT $ getBy $ UniqueProject prj sid
+                    t <- MaybeT $ getValBy $ UniqueTicket jid num
+                    return (sid, projectInbox j, projectFollowers j, t)
+                (sid, ibidProject, fsidProject, 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
+                lift $ insertUnique_ $ Follow pid (ticketFollowers t) False
+                return (did, Left <$> mmidParent, Just (sid, ticketFollowers t, ibidProject, fsidProject))
+            Nothing -> do
+                (rd, rdnew) <- lift $ do
+                    let (hContext, luContext) = f2l uContext
+                    iid <- either entityKey id <$> insertBy' (Instance hContext)
+                    mrd <- getValBy $ UniqueRemoteDiscussionIdent iid luContext
+                    case mrd of
+                        Just rd -> return (rd, False)
+                        Nothing -> do
+                            did <- insert Discussion
+                            let rd = RemoteDiscussion iid luContext did
+                            erd <- insertBy' rd
+                            case erd of
+                                Left (Entity _ rd') -> do
+                                    delete did
+                                    return (rd', False)
+                                Right _ -> 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 source content
+        moreRemotes <- deliverLocal pid obid localRecips mcollections
+        unless (federation || null moreRemotes) $
+            throwE "Federation disabled but remote collection members found"
+        remotesHttp <- lift $ deliverRemoteDB (furiHost uContext) obid remoteRecips moreRemotes
+        return (lmid, obid, doc, remotesHttp)
+    lift $ forkWorker "Outbox POST handler: async HTTP delivery" $ deliverRemoteHttp (furiHost uContext) obid doc remotesHttp
+    return lmid
+    where
+    verifyNothing :: Monad m => Maybe a -> e -> ExceptT e m ()
+    verifyNothing Nothing  _ = return ()
+    verifyNothing (Just _) e = throwE e
+
+    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
+        let remotes' = remotes L.\\ audienceNonActors aud
+        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 (ProjectFollowersR shr prj) =
+                Just $ LocalSharerRelated shr $ LocalProjectRelated prj LocalProjectFollowers
+            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
+                                    ( bimap (not . null) (not . null)
+                                    . partition id
+                                    )
+                                    ( 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 False
+            lpr2e LocalProjectFollowers        = Left True
+            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
+            localProjectRelatedSet (f, j) t =
+                LocalProjectRelatedSet j f t
+
+        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"
+            unless (localRecipProjectFollowers lprSet) $ throwE "Note context's project followers 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
+
+    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
+        -> Text
+        -> AppDB (LocalMessageId, OutboxItemId, Doc Activity)
+    insertMessage luAttrib shrUser pid uContext did muParent meparent source content = do
+        now <- liftIO getCurrentTime
+        mid <- insert Message
+            { messageCreated = now
+            , messageSource  = source
+            , messageContent = content
+            , messageParent  =
+                case meparent of
+                    Just (Left midParent) -> Just midParent
+                    _                     -> Nothing
+            , messageRoot    = did
+            }
+        let activity luAct luNote = Doc host Activity
+                { activityId       = luAct
+                , activityActor    = luAttrib
+                , activityAudience = aud
+                , activitySpecific = CreateActivity Create
+                    { createObject = Note
+                        { noteId        = Just luNote
+                        , noteAttrib    = luAttrib
+                        , noteAudience  = aud
+                        , noteReplyTo   = Just $ fromMaybe uContext muParent
+                        , noteContext   = Just uContext
+                        , notePublished = Just now
+                        , noteContent   = content
+                        }
+                    }
+                }
+            tempUri = LocalURI "" ""
+        obid <- insert OutboxItem
+            { outboxItemPerson    = pid
+            , outboxItemActivity  = PersistJSON $ activity tempUri tempUri
+            , outboxItemPublished = now
+            }
+        lmid <- insert LocalMessage
+            { localMessageAuthor         = pid
+            , localMessageRest           = mid
+            , localMessageCreate         = obid
+            , localMessageUnlinkedParent =
+                case meparent of
+                    Just (Right uParent) -> Just uParent
+                    _                    -> Nothing
+            }
+        route2local <- getEncodeRouteLocal
+        obhid <- encodeKeyHashid obid
+        lmhid <- encodeKeyHashid lmid
+        let luAct = route2local $ OutboxItemR shrUser obhid
+            luNote = route2local $ MessageR shrUser lmhid
+            doc = activity luAct luNote
+        update obid [OutboxItemActivity =. PersistJSON doc]
+        return (lmid, obid, doc)
+
+    -- 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
+        :: PersonId
+        -> OutboxItemId
+        -> [ShrIdent]
+        -> Maybe (SharerId, FollowerSetId, InboxId, FollowerSetId)
+        -> ExceptT Text AppDB [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))]
+    deliverLocal pidAuthor obid recips mticket = do
+        recipPids <- traverse getPersonId $ nub recips
+        when (pidAuthor `elem` recipPids) $
+            throwE "Note addressed to note author"
+        (morePids, remotes) <-
+            lift $ case mticket of
+                Nothing -> return ([], [])
+                Just (sid, fsidT, _, fsidJ) -> do
+                    (teamPids, teamRemotes) <- getTicketTeam sid
+                    (tfsPids, tfsRemotes) <- getFollowers fsidT
+                    (jfsPids, jfsRemotes) <- getFollowers fsidJ
+                    return
+                        ( L.delete pidAuthor $ union teamPids $ union tfsPids jfsPids
+                          -- 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` fst4)) $ mergeConcat3 teamRemotes tfsRemotes jfsRemotes
+                        )
+        lift $ do
+            for_ mticket $ \ (_, _, ibidProject, _) -> do
+                ibiid <- insert $ InboxItem False
+                insert_ $ InboxItemLocal ibidProject obid ibiid
+            for_ (union recipPids morePids) $ \ pid -> do
+                ibid <- personInbox <$> getJust pid
+                ibiid <- insert $ InboxItem True
+                insert_ $ InboxItemLocal ibid obid ibiid
+        return remotes
+        where
+        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"
+
+    {-
+    -- 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"
+    -}
+
+    deliverRemoteDB
+        :: Text
+        -> OutboxItemId
+        -> [FedURI]
+        -> [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))]
+        -> AppDB
+            ( [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, DeliveryId))]
+            , [((InstanceId, Text), NonEmpty (UnfetchedRemoteActorId, LocalURI, UnlinkedDeliveryId))]
+            , [((InstanceId, Text), NonEmpty (UnfetchedRemoteActorId, LocalURI, UnlinkedDeliveryId))]
+            )
+    deliverRemoteDB hContext obid recips known = 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, Nothing, Just lus'))
+                else do
+                    es <- for lus' $ \ lu -> do
+                        ma <- runMaybeT
+                            $   RecipRA <$> MaybeT (getBy $ UniqueRemoteActor iid lu)
+                            <|> RecipURA <$> MaybeT (getBy $ UniqueUnfetchedRemoteActor iid lu)
+                            <|> RecipRC <$> MaybeT (getBy $ UniqueRemoteCollection iid lu)
+                        return $
+                            case ma of
+                                Nothing -> Just $ Left lu
+                                Just r ->
+                                    case r of
+                                        RecipRA (Entity raid ra) -> Just $ Right $ Left (raid, remoteActorIdent ra, remoteActorInbox ra, remoteActorErrorSince ra)
+                                        RecipURA (Entity uraid ura) -> Just $ Right $ Right (uraid, unfetchedRemoteActorIdent ura, 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'
+            -- TODO see the earlier TODO about merge, it applies here too
+            allFetched = map (second $ NE.nubBy ((==) `on` fst4)) $ mergeConcat known moreKnown
+        fetchedDeliv <- for allFetched $ \ (i, rs) ->
+            let fwd = snd i == hContext
+            in  (i,) <$> insertMany' (\ (raid, _, _, msince) -> Delivery raid obid fwd $ isNothing msince) rs
+        unfetchedDeliv <- for unfetched $ \ (i, rs) ->
+            let fwd = snd i == hContext
+            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?
+            rs <- insertMany' (\ lu -> UnfetchedRemoteActor (fst i) lu Nothing) lus
+            let fwd = snd i == hContext
+            (i,) <$> insertMany' (\ (_, uraid) -> UnlinkedDelivery uraid obid fwd True) rs
+        return
+            ( takeNoError4 fetchedDeliv
+            , takeNoError3 unfetchedDeliv
+            , map
+                (second $ NE.map $ \ ((lu, ak), dlk) -> (ak, lu, dlk))
+                unknownDeliv
+            )
+        where
+        groupByHost :: [FedURI] -> [(Text, NonEmpty LocalURI)]
+        groupByHost = groupAllExtract furiHost (snd . f2l)
+
+        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 ((ak, luA, luI, Nothing), dlk) = Just (ak, luA, luI, dlk)
+            noError ((_ , _  , _  , Just _ ), _  ) = Nothing
+
+    deliverRemoteHttp
+        :: Text
+        -> OutboxItemId
+        -> Doc Activity
+        -> ( [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, DeliveryId))]
+           , [((InstanceId, Text), NonEmpty (UnfetchedRemoteActorId, LocalURI, UnlinkedDeliveryId))]
+           , [((InstanceId, Text), NonEmpty (UnfetchedRemoteActorId, LocalURI, UnlinkedDeliveryId))]
+           )
+        -> Worker ()
+    deliverRemoteHttp hContext obid doc (fetched, unfetched, unknown) = do
+        logDebug' "Starting"
+        let deliver fwd h inbox = do
+                let fwd' = if h == hContext then Just fwd else Nothing
+                (isJust fwd',) <$> deliverHttp doc fwd' h inbox
+        now <- liftIO getCurrentTime
+        logDebug' $
+            "Launching fetched " <> T.pack (show $ map (snd . fst) fetched)
+        traverse_ (fork . deliverFetched deliver now) fetched
+        logDebug' $
+            "Launching unfetched " <> T.pack (show $ map (snd . fst) unfetched)
+        traverse_ (fork . deliverUnfetched deliver now) unfetched
+        logDebug' $
+            "Launching unknown " <> T.pack (show $ map (snd . fst) unknown)
+        traverse_ (fork . deliverUnfetched deliver now) unknown
+        logDebug' "Done (async delivery may still be running)"
+        where
+        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 <", renderFedURI $ l2f 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 <", renderFedURI $ l2f 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 ", 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 ", h, t]
+
+getFollowersCollection
+    :: Route App -> AppDB FollowerSetId -> Handler TypedContent
+getFollowersCollection here getFsid = do
+    (locals, remotes) <- runDB $ do
+        fsid <- getFsid
+        (,) <$> do  pids <- map (followPerson . entityVal) <$>
+                        selectList [FollowTarget ==. fsid] []
+                    sids <-
+                        map (personIdent . entityVal) <$>
+                            selectList [PersonId <-. pids] []
+                    map (sharerIdent . entityVal) <$>
+                        selectList [SharerId <-. sids] []
+            <*> do  E.select $ E.from $ \ (rf `E.InnerJoin` ra `E.InnerJoin` i) -> do
+                        E.on $ ra E.^. RemoteActorInstance E.==. i E.^. InstanceId
+                        E.on $ rf E.^. RemoteFollowActor E.==. ra E.^. RemoteActorId
+                        E.where_ $ rf E.^. RemoteFollowTarget E.==. E.val fsid
+                        return
+                            ( i E.^. InstanceHost
+                            , ra E.^. RemoteActorIdent
+                            )
+
+    encodeRouteLocal <- getEncodeRouteLocal
+    encodeRouteHome <- getEncodeRouteHome
+    let followersAP = Collection
+            { collectionId         = encodeRouteLocal here
+            , collectionType       = CollectionTypeUnordered
+            , collectionTotalItems = Just $ length locals + length remotes
+            , collectionCurrent    = Nothing
+            , collectionFirst      = Nothing
+            , collectionLast       = Nothing
+            , collectionItems      =
+                map (encodeRouteHome . SharerR) locals ++
+                map (uncurry l2f . bimap E.unValue E.unValue) remotes
+            }
+    provideHtmlAndAP followersAP $ redirect (here, [("prettyjson", "true")])

src/Vervis/ActivityPub.hs

@@ -0,0 +1,251 @@
+{- 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 Vervis.ActivityPub
+    ( hostIsLocal
+    , verifyHostLocal
+    , parseContext
+    , parseParent
+    , runDBExcept
+    , getLocalParentMessageId
+    , concatRecipients
+    , getPersonOrGroupId
+    , getTicketTeam
+    , getFollowers
+    , mergeConcat
+    , mergeConcat3
+    , insertMany'
+    , isInstanceErrorP
+    , isInstanceErrorG
+    , deliverHttp
+    )
+where
+
+import Prelude
+
+import Control.Exception hiding (try)
+import Control.Monad
+import Control.Monad.IO.Class
+import Control.Monad.IO.Unlift
+import Control.Monad.Trans.Class
+import Control.Monad.Trans.Except
+import Control.Monad.Trans.Reader
+import Data.Bifunctor
+import Data.Function
+import Data.List.NonEmpty (NonEmpty, nonEmpty)
+import Data.Semigroup
+import Data.Text (Text)
+import Data.Time.Clock
+import Database.Persist
+import Database.Persist.Sql
+import Network.HTTP.Client
+import Network.TLS -- hiding (SHA256)
+import UnliftIO.Exception (try)
+
+import qualified Data.List.NonEmpty as NE
+import qualified Data.List.Ordered as LO
+import qualified Database.Esqueleto as E
+
+import Network.FedURI
+import Web.ActivityPub
+import Yesod.ActivityPub
+import Yesod.MonadSite
+import Yesod.FedURI
+import Yesod.Hashids
+
+import Control.Monad.Trans.Except.Local
+import Data.Either.Local
+import Data.List.NonEmpty.Local
+import Database.Persist.Local
+
+import Vervis.Foundation
+import Vervis.Model
+import Vervis.Model.Ident
+import Vervis.Settings
+
+hostIsLocal :: (MonadSite m, SiteEnv m ~ App) => Text -> m Bool
+hostIsLocal h = asksSite $ (== h) . appInstanceHost . appSettings
+
+verifyHostLocal
+    :: (MonadSite m, SiteEnv m ~ App)
+    => Text -> Text -> ExceptT Text m ()
+verifyHostLocal h t = do
+    local <- hostIsLocal h
+    unless local $ throwE t
+
+parseContext
+    :: (MonadSite m, SiteEnv m ~ App)
+    => FedURI
+    -> ExceptT Text m (Either (ShrIdent, PrjIdent, Int) (Text, LocalURI))
+parseContext uContext = do
+    let c@(hContext, luContext) = f2l uContext
+    local <- hostIsLocal hContext
+    if local
+        then Left <$> 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"
+        else return $ Right c
+
+parseParent
+    :: (MonadSite m, SiteEnv m ~ App)
+    => FedURI
+    -> ExceptT Text m (Either (ShrIdent, LocalMessageId) (Text, LocalURI))
+parseParent uParent = do
+    let p@(hParent, luParent) = f2l uParent
+    local <- hostIsLocal hParent
+    if local
+        then Left <$> do
+            route <- case decodeRouteLocal luParent of
+                Nothing -> throwE "Local parent isn't a valid route"
+                Just r -> return r
+            case route of
+                MessageR shr lmkhid ->
+                    (shr,) <$>
+                        decodeKeyHashidE lmkhid
+                            "Local parent has non-existent message \
+                            \hashid"
+                _ -> throwE "Local parent isn't a message route"
+        else return $ Right p
+
+newtype FedError = FedError Text deriving Show
+
+instance Exception FedError
+
+runDBExcept :: (MonadUnliftIO m, MonadSite m, SiteEnv m ~ App) => ExceptT Text (ReaderT SqlBackend m) a -> ExceptT Text m a
+runDBExcept action = do
+    result <-
+        lift $ try $ runSiteDB $ either abort return =<< runExceptT action
+    case result of
+        Left (FedError t) -> throwE t
+        Right r -> return r
+    where
+    abort = liftIO . throwIO . FedError
+
+getLocalParentMessageId :: DiscussionId -> ShrIdent -> LocalMessageId -> ExceptT Text AppDB MessageId
+getLocalParentMessageId did shr lmid = do
+    mlm <- lift $ get lmid
+    lm <- fromMaybeE mlm "Local parent: no such lmid"
+    p <- lift $ getJust $ localMessageAuthor lm
+    s <- lift $ getJust $ personIdent p
+    unless (shr == sharerIdent s) $ throwE "Local parent: No such message, lmid mismatches sharer"
+    let mid = localMessageRest lm
+    m <- lift $ getJust mid
+    unless (messageRoot m == did) $
+        throwE "Local parent belongs to a different discussion"
+    return mid
+
+concatRecipients :: Audience -> [FedURI]
+concatRecipients (Audience to bto cc bcc gen _) = concat [to, bto, cc, bcc, gen]
+
+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"
+
+getTicketTeam :: SharerId -> AppDB ([PersonId], [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))])
+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 (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))])
+getFollowers fsid = do
+    local <- selectList [FollowTarget ==. fsid] []
+    remote <- E.select $ E.from $ \ (rf `E.InnerJoin` rs `E.InnerJoin` i) -> do
+        E.on $ rs E.^. RemoteActorInstance E.==. i E.^. InstanceId
+        E.on $ rf E.^. RemoteFollowActor E.==. rs E.^. RemoteActorId
+        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.^. RemoteActorId
+            , rs E.^. RemoteActorIdent
+            , rs E.^. RemoteActorInbox
+            , rs E.^. RemoteActorErrorSince
+            )
+    return
+        ( map (followPerson . entityVal) local
+        , groupRemotes $
+            map (\ (E.Value iid, E.Value h, E.Value rsid, E.Value luActor, E.Value luInbox, E.Value msince) ->
+                    (iid, h, rsid, luActor, luInbox, msince)
+                )
+                remote
+        )
+    where
+    groupRemotes :: [(InstanceId, Text, RemoteActorId, LocalURI, LocalURI, Maybe UTCTime)] -> [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))]
+    groupRemotes = groupWithExtractBy ((==) `on` fst) fst snd . map toTuples
+        where
+        toTuples (iid, h, rsid, luA, luI, ms) = ((iid, h), (rsid, luA, luI, ms))
+
+-- | 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
+
+mergeConcat3 :: (Ord a, Semigroup b) => [(a, b)] -> [(a, b)] -> [(a, b)] -> [(a, b)]
+mergeConcat3 xs ys zs = mergeConcat xs $ LO.mergeBy (compare `on` fst) ys zs
+
+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!"
+
+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
+
+deliverHttp
+    :: (MonadSite m, SiteEnv m ~ App)
+    => Doc Activity
+    -> Maybe LocalURI
+    -> Text
+    -> LocalURI
+    -> m (Either APPostError (Response ()))
+deliverHttp doc mfwd h luInbox =
+    deliverActivity (l2f h luInbox) (l2f h <$> mfwd) doc

src/Vervis/Federation/Discussion.hs

@@ -0,0 +1,448 @@
+{- 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 Vervis.Federation.Discussion
+    ( sharerCreateNoteRemoteF
+    , projectCreateNoteF
+    )
+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.Class
+import Control.Monad.Trans.Except
+import Control.Monad.Trans.Maybe
+--import Control.Monad.Trans.Reader
+--import Crypto.Hash
+--import Data.Aeson
+import Data.Bifunctor
+import Data.ByteString (ByteString)
+--import Data.Either
+import Data.Foldable
+import Data.Function
+import Data.List (sort, deleteBy, nub, union, unionBy, partition)
+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.Time.Units
+import Data.Traversable
+--import Data.Tuple
+import Database.Persist
+--import Database.Persist.Sql hiding (deleteBy)
+--import Network.HTTP.Client
+--import Network.HTTP.Types.Header
+--import Network.HTTP.Types.URI
+--import Network.TLS hiding (SHA256)
+--import UnliftIO.Exception (try)
+import Yesod.Core hiding (logError, logWarn, logInfo, logDebug)
+import Yesod.Persist.Core
+
+import qualified Data.ByteString.Lazy as BL
+import qualified Data.CaseInsensitive as CI
+--import qualified Data.List as L
+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 qualified Network.Wai as W
+
+--import Data.Time.Interval
+--import Network.HTTP.Signature hiding (requestHeaders)
+import Yesod.HttpSignature
+
+--import Crypto.PublicVerifKey
+import Database.Persist.JSON
+import Network.FedURI
+import Network.HTTP.Digest
+import Web.ActivityPub
+import Yesod.ActivityPub
+--import Yesod.Auth.Unverified
+import Yesod.FedURI
+--import Yesod.Hashids
+--import Yesod.MonadSite
+
+import Control.Monad.Trans.Except.Local
+--import Data.Aeson.Local
+--import Data.Either.Local
+--import Data.List.Local
+--import Data.List.NonEmpty.Local
+--import Data.Maybe.Local
+import Data.Tuple.Local
+import Database.Persist.Local
+import Yesod.Persist.Local
+
+import Vervis.ActivityPub
+--import Vervis.ActorKey
+import Vervis.Foundation
+import Vervis.Model
+import Vervis.Model.Ident
+--import Vervis.RemoteActorStore
+import Vervis.Settings
+
+sharerCreateNoteRemoteF now shrRecip iidSender raw activity (Note mluNote _ _ muParent muContext mpublished _ _) = do
+    _luNote <- fromMaybeE mluNote "Note without note id"
+    _published <- fromMaybeE mpublished "Note without 'published' field"
+    uContext <- fromMaybeE muContext "Note without context"
+    context <- parseContext uContext
+    mparent <-
+        case muParent of
+            Nothing -> return Nothing
+            Just uParent ->
+                if uParent == uContext
+                    then return Nothing
+                    else Just <$> parseParent uParent
+    ExceptT $ runDB $ do
+        personRecip <- do
+            sid <- getKeyBy404 $ UniqueSharer shrRecip
+            getValBy404 $ UniquePersonIdent sid
+        valid <- checkContextParent context mparent
+        case valid of
+            Left e -> return $ Left e
+            Right _ -> Right <$> insertToInbox (personInbox personRecip)
+    where
+    checkContextParent context mparent = runExceptT $ do
+        case context of
+            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"
+                for_ mparent $ \ parent ->
+                    case parent of
+                        Left (shrP, lmidP) ->
+                            void $ getLocalParentMessageId did shrP lmidP
+                        Right (hParent, luParent) -> do
+                            mrm <- lift $ runMaybeT $ do
+                                iid <- MaybeT $ getKeyBy $ UniqueInstance hParent
+                                MaybeT $ getValBy $ UniqueRemoteMessageIdent iid luParent
+                            for_ mrm $ \ rm -> do
+                                let mid = remoteMessageRest rm
+                                m <- lift $ getJust mid
+                                unless (messageRoot m == did) $
+                                    throwE "Remote parent belongs to a different discussion"
+            Right (hContext, luContext) -> do
+                mdid <- lift $ runMaybeT $ do
+                    iid <- MaybeT $ getKeyBy $ UniqueInstance hContext
+                    rd <- MaybeT $ getValBy $ UniqueRemoteDiscussionIdent iid luContext
+                    return $ remoteDiscussionDiscuss rd
+                for_ mparent $ \ parent ->
+                    case parent of
+                        Left (shrP, lmidP) -> do
+                            did <- fromMaybeE mdid "Local parent inexistent, no RemoteDiscussion"
+                            void $ getLocalParentMessageId did shrP lmidP
+                        Right (hParent, luParent) -> do
+                            mrm <- lift $ runMaybeT $ do
+                                iid <- MaybeT $ getKeyBy $ UniqueInstance hParent
+                                MaybeT $ getValBy $ UniqueRemoteMessageIdent iid luParent
+                            for_ mrm $ \ rm -> do
+                                let mid = remoteMessageRest rm
+                                m <- lift $ getJust mid
+                                did <- fromMaybeE mdid "Remote parent known, but no context RemoteDiscussion"
+                                unless (messageRoot m == did) $
+                                    throwE "Remote parent belongs to a different discussion"
+    insertToInbox ibidRecip = do
+        let luActivity = activityId activity
+            jsonObj = PersistJSON raw
+            ract = RemoteActivity iidSender luActivity jsonObj now
+        ractid <- either entityKey id <$> insertBy' ract
+        ibiid <- insert $ InboxItem True
+        mibrid <- insertUnique $ InboxItemRemote ibidRecip ractid ibiid
+        let recip = shr2text shrRecip
+        case mibrid of
+            Nothing -> do
+                delete ibiid
+                return $ "Activity already exists in inbox of /s/" <> recip
+            Just _ -> return $ "Activity inserted to inbox of /s/" <> recip
+
+data CreateNoteRecipColl
+    = CreateNoteRecipProjectFollowers
+    | CreateNoteRecipTicketParticipants
+    | CreateNoteRecipTicketTeam
+    deriving Eq
+
+projectCreateNoteF now shrRecip prjRecip iidSender hSender raidSender body raw activity audience (Note mluNote _ _ muParent muCtx mpub src content) = do
+    luNote <- fromMaybeE mluNote "Note without note id"
+    published <- fromMaybeE mpub "Note without 'published' field"
+    uContext <- fromMaybeE muCtx "Note without context"
+    context <- parseContext uContext
+    mparent <-
+        case muParent of
+            Nothing -> return Nothing
+            Just uParent ->
+                if uParent == uContext
+                    then return Nothing
+                    else Just <$> parseParent uParent
+    case context of
+        Right _ -> return $ recip <> " not using; context isn't local"
+        Left (shr, prj, num) ->
+            if shr /= shrRecip || prj /= prjRecip
+                then return $ recip <> " not using; context is a different project"
+                else do
+                    msig <- checkForward
+                    hLocal <- getsYesod $ appInstanceHost . appSettings
+                    let colls = findRelevantCollections hLocal num audience
+                    mremotesHttp <- runDBExcept $ do
+                        (sid, fsidProject, fsidTicket, jid, ibid, did, meparent) <- getContextAndParent num mparent
+                        lift $ join <$> do
+                            mmid <- insertToDiscussion luNote published ibid did meparent fsidTicket
+                            for mmid $ \ (ractid, mid) -> do
+                                updateOrphans luNote did mid
+                                for msig $ \ sig -> do
+                                    remoteRecips <- deliverLocal ractid colls sid fsidProject fsidTicket
+                                    (sig,) <$> deliverRemoteDB ractid jid sig remoteRecips
+                    lift $ for_ mremotesHttp $ \ (sig, remotesHttp) -> do
+                        let handler e = logError $ "Project inbox handler: delivery failed! " <> T.pack (displayException e)
+                        forkHandler handler $ deliverRemoteHttp sig remotesHttp
+                    return $ recip <> " inserted new ticket comment"
+    where
+    checkForward = join <$> do
+        let hSig = hForwardingSignature
+        msig <- maybeHeader hSig
+        for msig $ \ sig -> do
+            _proof <- withExceptT (T.pack . displayException) $ ExceptT $
+                let requires = [hDigest, hActivityPubForwarder]
+                in  prepareToVerifyHttpSigWith hSig False requires [] Nothing
+            forwarder <- requireHeader hActivityPubForwarder
+            renderUrl <- getUrlRender
+            let project = renderUrl $ ProjectR shrRecip prjRecip
+            return $
+                if forwarder == encodeUtf8 project
+                    then Just sig
+                    else Nothing
+        where
+        maybeHeader n = do
+            let n' = decodeUtf8 $ CI.original n
+            hs <- lookupHeaders n
+            case hs of
+                [] -> return Nothing
+                [h] -> return $ Just h
+                _ -> throwE $ n' <> " multiple headers found"
+        requireHeader n = do
+            let n' = decodeUtf8 $ CI.original n
+            mh <- maybeHeader n
+            case mh of
+                Nothing -> throwE $ n' <> " header not found"
+                Just h -> return h
+    findRelevantCollections hLocal numCtx = nub . mapMaybe decide . concatRecipients
+        where
+        decide u = do
+            let (h, lu) = f2l u
+            guard $ h == hLocal
+            route <- decodeRouteLocal lu
+            case route of
+                ProjectFollowersR shr prj
+                    | shr == shrRecip && prj == prjRecip
+                        -> Just CreateNoteRecipProjectFollowers
+                TicketParticipantsR shr prj num
+                    | shr == shrRecip && prj == prjRecip && num == numCtx
+                        -> Just CreateNoteRecipTicketParticipants
+                TicketTeamR shr prj num
+                    | shr == shrRecip && prj == prjRecip && num == numCtx
+                        -> Just CreateNoteRecipTicketTeam
+                _ -> Nothing
+    recip = T.concat ["/s/", shr2text shrRecip, "/p/", prj2text prjRecip]
+    getContextAndParent num mparent = do
+        mt <- lift $ do
+            sid <- getKeyBy404 $ UniqueSharer shrRecip
+            Entity jid j <- getBy404 $ UniqueProject prjRecip sid
+            fmap (jid, projectInbox j, projectFollowers j, sid ,) <$>
+                getValBy (UniqueTicket jid num)
+        (jid, ibid, fsidProject, sid, t) <- fromMaybeE mt "Context: No such local ticket"
+        let did = ticketDiscuss t
+        meparent <- for mparent $ \ parent ->
+            case parent of
+                Left (shrParent, lmidParent) -> Left <$> getLocalParentMessageId did shrParent lmidParent
+                Right p@(hParent, luParent) -> do
+                    mrm <- lift $ runMaybeT $ do
+                        iid <- MaybeT $ getKeyBy $ UniqueInstance hParent
+                        MaybeT $ getValBy $ UniqueRemoteMessageIdent iid luParent
+                    case mrm of
+                        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
+                        Nothing -> return $ Right $ l2f hParent luParent
+        return (sid, fsidProject, ticketFollowers t, jid, ibid, did, meparent)
+    insertToDiscussion luNote published ibid did meparent fsid = do
+        ractid <- either entityKey id <$> insertBy' RemoteActivity
+            { remoteActivityInstance = iidSender
+            , remoteActivityIdent    = activityId activity
+            , remoteActivityContent  = PersistJSON raw
+            , remoteActivityReceived = now
+            }
+        mid <- insert Message
+            { messageCreated = published
+            , messageSource  = src
+            , messageContent = content
+            , messageParent  =
+                case meparent of
+                    Just (Left midParent) -> Just midParent
+                    _                     -> Nothing
+            , messageRoot    = did
+            }
+        mrmid <- insertUnique RemoteMessage
+            { remoteMessageAuthor     = raidSender
+            , remoteMessageInstance   = iidSender
+            , remoteMessageIdent      = luNote
+            , remoteMessageRest       = mid
+            , remoteMessageCreate     = ractid
+            , remoteMessageLostParent =
+                case meparent of
+                    Just (Right uParent) -> Just uParent
+                    _                    -> Nothing
+            }
+        case mrmid of
+            Nothing -> do
+                delete mid
+                return Nothing
+            Just _ -> do
+                insertUnique_ $ RemoteFollow raidSender fsid False
+                ibiid <- insert $ InboxItem False
+                insert_ $ InboxItemRemote ibid ractid ibiid
+                return $ Just (ractid, mid)
+    updateOrphans luNote did mid = do
+        let uNote = l2f hSender luNote
+        related <- selectOrphans uNote (E.==.)
+        for_ related $ \ (E.Value rmidOrphan, E.Value midOrphan) -> do
+            logWarn $ T.concat
+                [ "Found parent for related orphan RemoteMessage #"
+                , T.pack (show rmidOrphan)
+                , ", setting its parent now to Message #"
+                , T.pack (show mid)
+                ]
+            update rmidOrphan [RemoteMessageLostParent =. Nothing]
+            update midOrphan [MessageParent =. Just mid]
+        unrelated <- selectOrphans uNote (E.!=.)
+        for_ unrelated $ \ (E.Value rmidOrphan, E.Value _midOrphan) ->
+            logWarn $ T.concat
+                [ "Found parent for unrelated orphan RemoteMessage #"
+                , T.pack (show rmidOrphan)
+                , ", NOT settings its parent to Message #"
+                , T.pack (show mid)
+                , " because they have different DiscussionId!"
+                ]
+        where
+        selectOrphans uNote op =
+            E.select $ E.from $ \ (rm `E.InnerJoin` m) -> do
+                E.on $ rm E.^. RemoteMessageRest E.==. m E.^. MessageId
+                E.where_ $
+                    rm E.^. RemoteMessageLostParent E.==. E.just (E.val uNote) E.&&.
+                    m E.^. MessageRoot `op` E.val did
+                return (rm E.^. RemoteMessageId, m E.^. MessageId)
+    deliverLocal
+        :: RemoteActivityId
+        -> [CreateNoteRecipColl]
+        -> SharerId
+        -> FollowerSetId
+        -> FollowerSetId
+        -> AppDB [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))]
+    deliverLocal ractid recips sid fsidProject fsidTicket = do
+        (teamPids, teamRemotes) <-
+            if CreateNoteRecipTicketTeam `elem` recips
+                then getTicketTeam sid
+                else return ([], [])
+        (tfsPids, tfsRemotes) <-
+            if CreateNoteRecipTicketParticipants `elem` recips
+                then getFollowers fsidTicket
+                else return ([], [])
+        (jfsPids, jfsRemotes) <-
+            if CreateNoteRecipProjectFollowers `elem` recips
+                then getFollowers fsidProject
+                else return ([], [])
+        let pids = union teamPids tfsPids `union` jfsPids
+            -- TODO inefficient, see the other TODOs about mergeConcat
+            remotes = map (second $ NE.nubBy ((==) `on` fst4)) $ mergeConcat3 teamRemotes tfsRemotes jfsRemotes
+        for_ pids $ \ pid -> do
+            ibid <- personInbox <$> getJust pid
+            ibiid <- insert $ InboxItem True
+            mibrid <- insertUnique $ InboxItemRemote ibid ractid ibiid
+            when (isNothing mibrid) $
+                delete ibiid
+        return remotes
+
+    deliverRemoteDB
+        :: RemoteActivityId
+        -> ProjectId
+        -> ByteString
+        -> [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))]
+        -> AppDB
+            [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId))]
+    deliverRemoteDB ractid jid sig recips = do
+        let body' = BL.toStrict body
+            deliv raid msince = Forwarding raid ractid body' jid sig $ isNothing msince
+        fetchedDeliv <- for recips $ \ (i, rs) ->
+            (i,) <$> insertMany' (\ (raid, _, _, msince) -> deliv raid msince) rs
+        return $ takeNoError4 fetchedDeliv
+        where
+        takeNoError noError = mapMaybe $ \ (i, rs) -> (i,) <$> nonEmpty (mapMaybe noError $ NE.toList rs)
+        takeNoError4 = takeNoError noError
+            where
+            noError ((ak, luA, luI, Nothing), dlk) = Just (ak, luA, luI, dlk)
+            noError ((_ , _  , _  , Just _ ), _  ) = Nothing
+
+    deliverRemoteHttp
+        :: ByteString
+        -> [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId))]
+        -> Handler ()
+    deliverRemoteHttp sig fetched = do
+        let deliver h inbox = do
+                forwardActivity (l2f h inbox) sig (ProjectR shrRecip prjRecip) body
+        now <- liftIO getCurrentTime
+        traverse_ (fork . deliverFetched deliver now) fetched
+        where
+        fork = forkHandler $ \ e -> logError $ "Project inbox handler: delivery failed! " <> T.pack (displayException e)
+        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 -> runDB $ 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
+                    runDB $
+                        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
+                            runDB $
+                                case e of
+                                    Left _err -> do
+                                        updateWhere [RemoteActorId ==. raid, RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now]
+                                        update fwid [ForwardingRunning =. False]
+                                    Right _resp -> delete fwid

src/Vervis/Handler/Discussion.hs

@@ -55,6 +55,7 @@ import Yesod.Hashids
 import Database.Persist.Local
 import Yesod.Persist.Local
 
+import Vervis.API
 import Vervis.Discussion
 import Vervis.Form.Discussion
 import Vervis.Federation
@@ -226,7 +227,7 @@ postTopReply hDest recipsA recipsC context replyP after = do
                 , noteSource    = msg'
                 , noteContent   = contentHtml
                 }
-        ExceptT $ handleOutboxNote hLocal note
+        ExceptT $ createNoteC hLocal note
     case elmid of
         Left e -> do
             setMessage $ toHtml e
@@ -309,7 +310,7 @@ postReply hDest recipsA recipsC context replyG replyP after getdid midParent = d
                 , noteSource    = msg'
                 , noteContent   = contentHtml
                 }
-        ExceptT $ handleOutboxNote hLocal note
+        ExceptT $ createNoteC hLocal note
     case elmid of
         Left e -> do
             setMessage $ toHtml e

src/Vervis/Handler/Inbox.hs

@@ -109,6 +109,7 @@ import Database.Persist.Local
 import Yesod.Persist.Local
 
 import Vervis.ActorKey
+import Vervis.API
 import Vervis.Federation
 import Vervis.Foundation
 import Vervis.Model
@@ -480,7 +481,7 @@ postOutboxR shrAuthor = do
                 , noteSource    = msg'
                 , noteContent   = contentHtml
                 }
-        ExceptT $ handleOutboxNote hLocal note
+        ExceptT $ createNoteC hLocal note
     case elmid of
         Left err -> setMessage $ toHtml err
         Right lmid -> do

src/Vervis/Handler/Project.hs

@@ -59,6 +59,7 @@ import Data.Either.Local
 import Database.Persist.Local
 import Yesod.Persist.Local
 
+import Vervis.API
 import Vervis.Federation
 import Vervis.Form.Project
 import Vervis.Foundation

src/Vervis/Handler/Ticket.hs

@@ -101,6 +101,7 @@ import Data.Maybe.Local (partitionMaybePairs)
 import Database.Persist.Local
 import Yesod.Persist.Local
 
+import Vervis.API
 import Vervis.Federation
 import Vervis.Form.Ticket
 import Vervis.Foundation

vervis.cabal

@@ -42,6 +42,7 @@ library
   exposed-modules:     Control.Applicative.Local
                        Control.Concurrent.Local
                        Control.Concurrent.ResultShare
+                       Control.Monad.Trans.Except.Local
                        Crypto.PubKey.Encoding
                        Crypto.PublicVerifKey
                        Darcs.Local.Repository
@@ -75,6 +76,7 @@ library
                        Data.Text.Lazy.UTF8.Local
                        Data.Time.Clock.Local
                        Data.Tree.Local
+                       Data.Tuple.Local
                        Database.Esqueleto.Local
                        Database.Persist.Class.Local
                        Database.Persist.JSON
@@ -111,8 +113,10 @@ library
                        Yesod.SessionEntity
 
                        Vervis.Access
+                       Vervis.ActivityPub
                        Vervis.ActivityStreams
                        Vervis.ActorKey
+                       Vervis.API
                        Vervis.Application
                        Vervis.Avatar
                        Vervis.BinaryBody
@@ -123,6 +127,7 @@ library
                        Vervis.Darcs
                        Vervis.Discussion
                        Vervis.Federation
+                       Vervis.Federation.Discussion
                        Vervis.Field.Key
                        Vervis.Field.Person
                        Vervis.Field.Project