S2S: Implement preparation and generic steps in person inbox post handler

The steps are:

- Parse activity ID and match with the authenticated sender
- For local activity (we got via forwarding), find in DB
- For remote activity, cache in DB
- Insert activity to recipient's inbox

What's not there yet is the actual logic of handling specific activities.

src/Vervis/API.hs

@@ -118,6 +118,7 @@ import Vervis.ActivityPub
 import Vervis.ActorKey
 import Vervis.Cloth
 import Vervis.Darcs
+import Vervis.Data.Collab
 import Vervis.Delivery
 import Vervis.Discussion
 import Vervis.FedURI
@@ -1800,9 +1801,6 @@ followC (Entity pidSender personSender) summary audience follow@(AP.Follow uObje
         ibiid <- insert $ InboxItem True
         insert_ $ InboxItemLocal ibidAuthor obiidAccept ibiid
 
-data GrantRecipBy f = GrantRecipPerson (f Person)
-    deriving (Generic, FunctorB, TraversableB, ConstraintsB)
-
 data Result
     = ResultSomeException SomeException
     | ResultIdMismatch
@@ -1821,7 +1819,7 @@ grantC
 grantC (Entity pidUser personUser) senderActor muCap summary audience grant = do
 
     -- Check input
-    (resource, recipient) <- parseGrant grant
+    (resource, recipient) <- parseGrant (Just pidUser) grant
     ParsedAudience localRecips remoteRecips blinded fwdHosts <- do
         mrecips <- parseAudience audience
         recips <- fromMaybeE mrecips "Grant with no recipients"
@@ -1966,78 +1964,6 @@ grantC (Entity pidUser personUser) senderActor muCap summary audience grant = do
 
     where
 
-    parseGrantResource (RepoR r) = Just $ GrantResourceRepo r
-    parseGrantResource (DeckR d) = Just $ GrantResourceDeck d
-    parseGrantResource (LoomR l) = Just $ GrantResourceLoom l
-    parseGrantResource _         = Nothing
-
-    parseGrantRecip (PersonR p) = Just $ GrantRecipPerson p
-    parseGrantRecip _           = Nothing
-
-    unhashGrantRecipPure ctx = f
-        where
-        f (GrantRecipPerson p) =
-            GrantRecipPerson <$> decodeKeyHashidPure ctx p
-
-    unhashGrantRecip resource = do
-        ctx <- asksSite siteHashidsContext
-        return $ unhashGrantRecipPure ctx resource
-
-    unhashGrantRecipE resource e =
-        ExceptT $ maybe (Left e) Right <$> unhashGrantRecip resource
-
-    parseGrant
-        :: Grant URIMode
-        -> ExceptT Text Handler
-            ( Either (GrantResourceBy Key) FedURI
-            , Either (GrantRecipBy Key) FedURI
-            )
-    parseGrant (Grant object context target) = do
-        verifyRole object
-        (,) <$> parseContext context
-            <*> parseTarget target
-        where
-        verifyRole (Left RoleAdmin) = pure ()
-        verifyRole (Right _) =
-            throwE "ForgeFed Admin is the only role allowed currently"
-        parseContext u@(ObjURI h lu) = do
-            hl <- hostIsLocal h
-            if hl
-                then Left <$> do
-                    route <-
-                        fromMaybeE
-                            (decodeRouteLocal lu)
-                            "Grant context isn't a valid route"
-                    resourceHash <-
-                        fromMaybeE
-                            (parseGrantResource route)
-                            "Grant context isn't a shared resource route"
-                    unhashGrantResourceE
-                        resourceHash
-                        "Grant resource contains invalid hashid"
-                else pure $ Right u
-        parseTarget u@(ObjURI h lu) = do
-            hl <- hostIsLocal h
-            if hl
-                then Left <$> do
-                    route <-
-                        fromMaybeE
-                            (decodeRouteLocal lu)
-                            "Grant target isn't a valid route"
-                    recipHash <-
-                        fromMaybeE
-                            (parseGrantRecip route)
-                            "Grant target isn't a grant recipient route"
-                    recipKey <-
-                        unhashGrantRecipE
-                            recipHash
-                            "Grant target contains invalid hashid"
-                    case recipKey of
-                        GrantRecipPerson p | p == pidUser ->
-                            throwE "Grant sender and recipient are the same Person"
-                        _ -> return recipKey
-                else pure $ Right u
-
     fetchRemoteResource instanceID host localURI = do
         maybeActor <- runSiteDB $ runMaybeT $ do
             roid <- MaybeT $ getKeyBy $ UniqueRemoteObject instanceID localURI

src/Vervis/ActivityPub.hs

@@ -32,6 +32,7 @@ module Vervis.ActivityPub
     , parseActivityURI
     , getActivity
     --, ActorEntity (..)
+    , getLocalActor'
     , getLocalActor
     --, getOutboxActorEntity
     --, actorEntityPath
@@ -332,6 +333,29 @@ data ActorEntity
     | ActorRepo (Entity Repo)
 -}
 
+getLocalActor'
+    :: ( BaseBackend b ~ SqlBackend
+       , PersistUniqueRead b
+       , MonadIO m
+       )
+    => ActorId
+    -> ReaderT b m (LocalActorBy Key)
+getLocalActor' actorID = do
+    mp <- getKeyBy $ UniquePersonActor actorID
+    mg <- getKeyBy $ UniqueGroupActor actorID
+    mr <- getKeyBy $ UniqueRepoActor actorID
+    md <- getKeyBy $ UniqueDeckActor actorID
+    ml <- getKeyBy $ UniqueLoomActor actorID
+    return $
+        case (mp, mg, mr, md, ml) of
+            (Nothing, Nothing, Nothing, Nothing, Nothing) -> error "Unused ActorId"
+            (Just p, Nothing, Nothing, Nothing, Nothing) -> LocalActorPerson p
+            (Nothing, Just g, Nothing, Nothing, Nothing) -> LocalActorGroup g
+            (Nothing, Nothing, Just r, Nothing, Nothing) -> LocalActorRepo r
+            (Nothing, Nothing, Nothing, Just d, Nothing) -> LocalActorDeck d
+            (Nothing, Nothing, Nothing, Nothing, Just l) -> LocalActorLoom l
+            _ -> error "Multi-usage of an ActorId"
+
 getLocalActor
     :: ( BaseBackend b ~ SqlBackend
        , PersistUniqueRead b

src/Vervis/Actor.hs

@@ -15,6 +15,7 @@
 
 module Vervis.Actor
     ( getInbox
+    , postInbox
     , getOutbox
     , getOutboxItem
     , getFollowersCollection
@@ -213,6 +214,61 @@ getInbox here actor hash = do
         where
         ibiidString = "InboxItem #" ++ show (fromSqlKey ibid)
 
+postInbox
+    :: (   UTCTime
+        -> ActivityAuthentication
+        -> ActivityBody
+        -> ExceptT Text Handler
+            ( Text
+            , Maybe (ExceptT Text Worker Text)
+            )
+       )
+    -> Handler ()
+postInbox handler = do
+    federation <- getsYesod $ appFederation . appSettings
+    unless federation badMethod
+    contentTypes <- lookupHeaders "Content-Type"
+    now <- liftIO getCurrentTime
+    result <- runExceptT $ do
+        (auth, body) <- authenticateActivity now
+        (actbObject body,) <$> handler now auth body
+    recordActivity now result contentTypes
+    case result of
+        Left err -> do
+            logDebug err
+            sendResponseStatus badRequest400 err
+        Right (obj, (_, mworker)) ->
+            for_ mworker $ \ worker -> forkWorker "postInbox worker" $ do
+                wait <- asyncWorker $ runExceptT worker
+                result' <- wait
+                let result'' =
+                        case result' of
+                            Left e -> Left $ T.pack $ displayException e
+                            Right (Left e) -> Left e
+                            Right (Right t) -> Right (obj, (t, Nothing))
+                now' <- liftIO getCurrentTime
+                recordActivity now' result'' contentTypes
+                case result'' of
+                    Left err -> logDebug err
+                    Right _ -> return ()
+    where
+    recordActivity
+        :: (MonadSite m, SiteEnv m ~ App)
+        => UTCTime -> Either Text (Object, (Text, w)) -> [ContentType] -> m ()
+    recordActivity now result contentTypes = do
+        macts <- asksSite appActivities
+        for_ macts $ \ (size, acts) ->
+            liftIO $ atomically $ modifyTVar' acts $ \ vec ->
+                let (msg, body) =
+                        case result of
+                            Left t -> (t, "{?}")
+                            Right (o, (t, _)) -> (t, encodePretty o)
+                    item = ActivityReport now msg contentTypes body
+                    vec' = item `V.cons` vec
+                in  if V.length vec' > size
+                        then V.init vec'
+                        else vec'
+
 getOutbox here actor hash = do
     key <- decodeKeyHashid404 hash
     (total, pages, mpage) <- runDB $ do

src/Vervis/Data/Actor.hs

@@ -0,0 +1,56 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2022 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.Data.Actor
+    ( parseLocalActivityURI
+    )
+where
+
+import Control.Monad.Trans.Except
+import Data.Text (Text)
+
+import Network.FedURI
+import Yesod.FedURI
+import Yesod.Hashids
+import Yesod.MonadSite
+
+import Control.Monad.Trans.Except.Local
+
+import Vervis.Foundation
+import Vervis.Model
+import Vervis.Recipient
+
+parseLocalActivityURI
+    :: (MonadSite m, YesodHashids (SiteEnv m))
+    => LocalURI
+    -> ExceptT Text m (LocalActorBy Key, LocalActorBy KeyHashid, OutboxItemId)
+parseLocalActivityURI luAct = do
+    route <-
+        fromMaybeE (decodeRouteLocal luAct) "Local activity: Not a valid route"
+    (actorHash, outboxItemHash) <-
+        fromMaybeE
+            (parseOutboxItemRoute route)
+            "Local activity: Valid local route, but not an outbox item route"
+    outboxItemID <-
+        decodeKeyHashidE outboxItemHash "Local activity: Invalid outbox item hash"
+    actorKey <- unhashLocalActorE actorHash "Local activity: Invalid actor hash"
+    return (actorKey, actorHash, outboxItemID)
+    where
+    parseOutboxItemRoute (PersonOutboxItemR p i) = Just (LocalActorPerson p, i)
+    parseOutboxItemRoute (GroupOutboxItemR g i)  = Just (LocalActorGroup g, i)
+    parseOutboxItemRoute (RepoOutboxItemR r i)   = Just (LocalActorRepo r, i)
+    parseOutboxItemRoute (DeckOutboxItemR d i)   = Just (LocalActorDeck d, i)
+    parseOutboxItemRoute (LoomOutboxItemR l i)   = Just (LocalActorLoom l, i)
+    parseOutboxItemRoute _                       = Nothing

src/Vervis/Data/Collab.hs

@@ -0,0 +1,119 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2022 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/>.
+ -}
+
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+
+module Vervis.Data.Collab
+    ( GrantRecipBy (..)
+    , parseGrant
+    )
+where
+
+import Control.Monad.Trans.Except
+import Data.Barbie
+import Data.Text (Text)
+import Database.Persist.Types
+import GHC.Generics
+
+import Network.FedURI
+import Web.ActivityPub
+import Yesod.ActivityPub
+import Yesod.FedURI
+import Yesod.Hashids
+import Yesod.MonadSite
+
+import Control.Monad.Trans.Except.Local
+
+import Vervis.Access
+import Vervis.FedURI
+import Vervis.Foundation
+import Vervis.Model
+
+data GrantRecipBy f = GrantRecipPerson (f Person)
+    deriving (Generic, FunctorB, TraversableB, ConstraintsB)
+
+parseGrantRecip (PersonR p) = Just $ GrantRecipPerson p
+parseGrantRecip _           = Nothing
+
+unhashGrantRecipPure ctx = f
+    where
+    f (GrantRecipPerson p) =
+        GrantRecipPerson <$> decodeKeyHashidPure ctx p
+
+unhashGrantRecip resource = do
+    ctx <- asksSite siteHashidsContext
+    return $ unhashGrantRecipPure ctx resource
+
+unhashGrantRecipE resource e =
+    ExceptT $ maybe (Left e) Right <$> unhashGrantRecip resource
+
+parseGrant
+    :: Maybe PersonId
+    -> Grant URIMode
+    -> ExceptT Text Handler
+        ( Either (GrantResourceBy Key) FedURI
+        , Either (GrantRecipBy Key) FedURI
+        )
+parseGrant maybeSenderID (Grant object context target) = do
+    verifyRole object
+    (,) <$> parseContext context
+        <*> parseTarget target
+    where
+    verifyRole (Left RoleAdmin) = pure ()
+    verifyRole (Right _) =
+        throwE "ForgeFed Admin is the only role allowed currently"
+    parseContext u@(ObjURI h lu) = do
+        hl <- hostIsLocal h
+        if hl
+            then Left <$> do
+                route <-
+                    fromMaybeE
+                        (decodeRouteLocal lu)
+                        "Grant context isn't a valid route"
+                resourceHash <-
+                    fromMaybeE
+                        (parseGrantResource route)
+                        "Grant context isn't a shared resource route"
+                unhashGrantResourceE
+                    resourceHash
+                    "Grant resource contains invalid hashid"
+            else pure $ Right u
+        where
+        parseGrantResource (RepoR r) = Just $ GrantResourceRepo r
+        parseGrantResource (DeckR d) = Just $ GrantResourceDeck d
+        parseGrantResource (LoomR l) = Just $ GrantResourceLoom l
+        parseGrantResource _         = Nothing
+    parseTarget u@(ObjURI h lu) = do
+        hl <- hostIsLocal h
+        if hl
+            then Left <$> do
+                route <-
+                    fromMaybeE
+                        (decodeRouteLocal lu)
+                        "Grant target isn't a valid route"
+                recipHash <-
+                    fromMaybeE
+                        (parseGrantRecip route)
+                        "Grant target isn't a grant recipient route"
+                recipKey <-
+                    unhashGrantRecipE
+                        recipHash
+                        "Grant target contains invalid hashid"
+                case recipKey of
+                    GrantRecipPerson p | Just p == maybeSenderID ->
+                        throwE "Grant sender and recipient are the same Person"
+                    _ -> return recipKey
+            else pure $ Right u

src/Vervis/Federation.hs

@@ -117,187 +117,6 @@ import Vervis.RemoteActorStore
 import Vervis.Settings
 
 {-
-handlePersonInbox
-    :: KeyHashid Person
-    -> ActivityAuthentication
-    -> ActivityBody
-    -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
-handlePersonInbox recipHash (ActivityAuthLocal (LocalActorPerson pidAuthor)) body = (,Nothing) <$> do
-    (shrActivity, obiid) <- do
-        luAct <-
-            fromMaybeE
-                (activityId $ actbActivity body)
-                "Local activity: No 'id'"
-        route <-
-            fromMaybeE
-                (decodeRouteLocal luAct)
-                "Local activity: Not a valid route"
-        case route of
-            SharerOutboxItemR shr obikhid ->
-                (shr,) <$> decodeKeyHashidE obikhid "Local activity: ID is invalid hashid"
-            _ -> throwE "Local activity: Not an activity route"
-    runDBExcept $ do
-        Entity pidRecip personRecip <- lift $ do
-            sid <- getKeyBy404 $ UniqueSharer shrRecip
-            getBy404 $ UniquePersonIdent sid
-        mobi <- lift $ get obiid
-        obi <- fromMaybeE mobi "Local activity: No such ID in DB"
-        mpidOutbox <-
-            lift $ getKeyBy $ UniquePersonOutbox $ outboxItemOutbox obi
-        pidOutbox <-
-            fromMaybeE mpidOutbox "Local activity not in a user outbox"
-        p <- lift $ getJust pidOutbox
-        s <- lift $ getJust $ personIdent p
-        unless (sharerIdent s == shrActivity) $
-            throwE "Local activity: ID invalid, hashid and author mismatch"
-        unless (pidAuthor == pidOutbox) $
-            throwE "Activity author in DB and in received JSON don't match"
-        if pidRecip == pidAuthor
-            then return "Received activity authored by self, ignoring"
-            else lift $ do
-                ibiid <- insert $ InboxItem True
-                let ibid = personInbox personRecip
-                miblid <- insertUnique $ InboxItemLocal ibid obiid ibiid
-                let recip = shr2text shrRecip
-                case miblid of
-                    Nothing -> do
-                        delete ibiid
-                        return $
-                            "Activity already exists in inbox of /s/" <> recip
-                    Just _ ->
-                        return $ "Activity inserted to inbox of /s/" <> recip
-handleSharerInbox shrRecip _now (ActivityAuthLocal (ActivityAuthLocalProject jidAuthor)) body = (,Nothing) <$> do
-    (shrActivity, prjActivity, obiid) <- do
-        luAct <-
-            fromMaybeE
-                (activityId $ actbActivity body)
-                "Local activity: No 'id'"
-        route <-
-            fromMaybeE
-                (decodeRouteLocal luAct)
-                "Local activity: Not a valid route"
-        case route of
-            ProjectOutboxItemR shr prj obikhid ->
-                (shr,prj,) <$> decodeKeyHashidE obikhid "Local activity: ID is invalid hashid"
-            _ -> throwE "Local activity: Not an activity route"
-    runDBExcept $ do
-        Entity pidRecip personRecip <- lift $ do
-            sid <- getKeyBy404 $ UniqueSharer shrRecip
-            getBy404 $ UniquePersonIdent sid
-        mobi <- lift $ get obiid
-        obi <- fromMaybeE mobi "Local activity: No such ID in DB"
-        maidOutbox <-
-            lift $ getKeyBy $ UniqueActorOutbox $ outboxItemOutbox obi
-        aidOutbox <-
-            fromMaybeE maidOutbox "Local activity not in an actor outbox"
-        mejOutbox <-
-            lift $ getBy $ UniqueProjectActor aidOutbox
-        Entity jidOutbox j <-
-            fromMaybeE mejOutbox "Local activity not in a project outbox"
-        s <- lift $ getJust $ projectSharer j
-        unless (sharerIdent s == shrActivity) $
-            throwE "Local activity: ID invalid, hashid and author shr mismatch"
-        unless (projectIdent j == prjActivity) $
-            throwE "Local activity: ID invalid, hashid and author prj mismatch"
-        unless (jidAuthor == jidOutbox) $
-            throwE "Activity author in DB and in received JSON don't match"
-        lift $ do
-            ibiid <- insert $ InboxItem True
-            let ibid = personInbox personRecip
-            miblid <- insertUnique $ InboxItemLocal ibid obiid ibiid
-            let recip = shr2text shrRecip
-            case miblid of
-                Nothing -> do
-                    delete ibiid
-                    return $
-                        "Activity already exists in inbox of /s/" <> recip
-                Just _ ->
-                    return $ "Activity inserted to inbox of /s/" <> recip
-handleSharerInbox shrRecip _now (ActivityAuthLocal (ActivityAuthLocalRepo ridAuthor)) body = (,Nothing) <$> do
-    (shrActivity, rpActivity, obiid) <- do
-        luAct <-
-            fromMaybeE
-                (activityId $ actbActivity body)
-                "Local activity: No 'id'"
-        route <-
-            fromMaybeE
-                (decodeRouteLocal luAct)
-                "Local activity: Not a valid route"
-        case route of
-            RepoOutboxItemR shr rp obikhid ->
-                (shr,rp,) <$> decodeKeyHashidE obikhid "Local activity: ID is invalid hashid"
-            _ -> throwE "Local activity: Not an activity route"
-    runDBExcept $ do
-        Entity pidRecip personRecip <- lift $ do
-            sid <- getKeyBy404 $ UniqueSharer shrRecip
-            getBy404 $ UniquePersonIdent sid
-        mobi <- lift $ get obiid
-        obi <- fromMaybeE mobi "Local activity: No such ID in DB"
-        mridOutbox <-
-            lift $ getKeyBy $ UniqueRepoOutbox $ outboxItemOutbox obi
-        ridOutbox <-
-            fromMaybeE mridOutbox "Local activity not in a repo outbox"
-        r <- lift $ getJust ridOutbox
-        s <- lift $ getJust $ repoSharer r
-        unless (sharerIdent s == shrActivity) $
-            throwE "Local activity: ID invalid, hashid and author shr mismatch"
-        unless (repoIdent r == rpActivity) $
-            throwE "Local activity: ID invalid, hashid and author rp mismatch"
-        unless (ridAuthor == ridOutbox) $
-            throwE "Activity author in DB and in received JSON don't match"
-        lift $ do
-            ibiid <- insert $ InboxItem True
-            let ibid = personInbox personRecip
-            miblid <- insertUnique $ InboxItemLocal ibid obiid ibiid
-            let recip = shr2text shrRecip
-            case miblid of
-                Nothing -> do
-                    delete ibiid
-                    return $
-                        "Activity already exists in inbox of /s/" <> recip
-                Just _ ->
-                    return $ "Activity inserted to inbox of /s/" <> recip
-handleSharerInbox shrRecip now (ActivityAuthRemote author) body = do
-    luActivity <-
-        fromMaybeE (activityId $ actbActivity body) "Activity without 'id'"
-    localRecips <- do
-        mrecips <- parseAudience $ activityAudience $ actbActivity body
-        paudLocalRecips <$> fromMaybeE mrecips "Activity with no recipients"
-    msig <- checkForwarding $ LocalActorSharer shrRecip
-    let mfwd = (localRecips,) <$> msig
-    case activitySpecific $ actbActivity body of
-        AcceptActivity accept ->
-            (,Nothing) <$> sharerAcceptF shrRecip now author body mfwd luActivity accept
-        AddActivity (AP.Add obj target) ->
-            case obj of
-                Right (AddBundle patches) ->
-                    sharerAddBundleF now shrRecip author body mfwd luActivity patches target
-                _ -> return ("Unsupported add object type for sharers", Nothing)
-        CreateActivity (Create obj mtarget) ->
-            case obj of
-                CreateNote _ note ->
-                    (,Nothing) <$> sharerCreateNoteF now shrRecip author body mfwd luActivity note
-                CreateTicket _ ticket ->
-                    (,Nothing) <$> sharerCreateTicketF now shrRecip author body mfwd luActivity ticket mtarget
-                _ -> return ("Unsupported create object type for sharers", Nothing)
-        FollowActivity follow ->
-            (,Nothing) <$> sharerFollowF shrRecip now author body mfwd luActivity follow
-        OfferActivity (Offer obj target) ->
-            case obj of
-                OfferTicket ticket ->
-                    (,Nothing) <$> sharerOfferTicketF now shrRecip author body mfwd luActivity ticket target
-                OfferDep dep ->
-                    sharerOfferDepF now shrRecip author body mfwd luActivity dep target
-                _ -> return ("Unsupported offer object type for sharers", Nothing)
-        PushActivity push ->
-            (,Nothing) <$> sharerPushF shrRecip now author body mfwd luActivity push
-        RejectActivity reject ->
-            (,Nothing) <$> sharerRejectF shrRecip now author body mfwd luActivity reject
-        ResolveActivity resolve ->
-            (,Nothing) <$> sharerResolveF now shrRecip author body mfwd luActivity resolve
-        UndoActivity undo ->
-            (,Nothing) <$> sharerUndoF shrRecip now author body mfwd luActivity undo
-        _ -> return ("Unsupported activity type for sharers", Nothing)
 
 handleProjectInbox
     :: ShrIdent

src/Vervis/Handler/Inbox.hs

@@ -160,61 +160,6 @@ getRepoInboxR shr rp = getInbox here getInboxId
         r <- getValBy404 $ UniqueRepo rp sid
         return $ repoInbox r
 
-recordActivity
-    :: (MonadSite m, SiteEnv m ~ App)
-    => UTCTime -> Either Text (Object, (Text, w)) -> [ContentType] -> m ()
-recordActivity now result contentTypes = do
-    macts <- asksSite appActivities
-    for_ macts $ \ (size, acts) ->
-        liftIO $ atomically $ modifyTVar' acts $ \ vec ->
-            let (msg, body) =
-                    case result of
-                        Left t -> (t, "{?}")
-                        Right (o, (t, _)) -> (t, encodePretty o)
-                item = ActivityReport now msg contentTypes body
-                vec' = item `V.cons` vec
-            in  if V.length vec' > size
-                    then V.init vec'
-                    else vec'
-
-handleInbox
-    :: (   UTCTime
-        -> ActivityAuthentication
-        -> ActivityBody
-        -> ExceptT Text Handler
-            ( Text
-            , Maybe (ExceptT Text Worker Text)
-            )
-       )
-    -> Handler ()
-handleInbox handler = do
-    federation <- getsYesod $ appFederation . appSettings
-    unless federation badMethod
-    contentTypes <- lookupHeaders "Content-Type"
-    now <- liftIO getCurrentTime
-    result <- runExceptT $ do
-        (auth, body) <- authenticateActivity now
-        (actbObject body,) <$> handler now auth body
-    recordActivity now result contentTypes
-    case result of
-        Left err -> do
-            logDebug err
-            sendResponseStatus badRequest400 err
-        Right (obj, (_, mworker)) ->
-            for_ mworker $ \ worker -> forkWorker "handleInbox worker" $ do
-                wait <- asyncWorker $ runExceptT worker
-                result' <- wait
-                let result'' =
-                        case result' of
-                            Left e -> Left $ T.pack $ displayException e
-                            Right (Left e) -> Left e
-                            Right (Right t) -> Right (obj, (t, Nothing))
-                now' <- liftIO getCurrentTime
-                recordActivity now' result'' contentTypes
-                case result'' of
-                    Left err -> logDebug err
-                    Right _ -> return ()
-
 postSharerInboxR :: ShrIdent -> Handler ()
 postSharerInboxR shrRecip = handleInbox $ handleSharerInbox shrRecip
 

src/Vervis/Handler/Person.hs

@@ -32,9 +32,13 @@ where
 
 import Control.Monad
 import Control.Monad.Trans.Except
+import Control.Monad.Trans.Reader
 import Data.Maybe
+import Data.Text (Text)
+import Data.Time.Clock
 import Data.Traversable
 import Database.Persist
+import Database.Persist.Sql
 import Dvara
 import Text.Blaze.Html (toHtml)
 import Yesod.Core
@@ -52,9 +56,11 @@ import Network.FedURI
 import Yesod.ActivityPub
 import Yesod.FedURI
 import Yesod.Hashids
+import Yesod.MonadSite
 
 import qualified Web.ActivityPub as AP
 
+import Control.Monad.Trans.Except.Local
 import Data.Either.Local
 import Database.Persist.Local
 
@@ -62,9 +68,12 @@ import Vervis.ActivityPub
 import Vervis.Actor
 import Vervis.ActorKey
 import Vervis.API
+import Vervis.Data.Actor
+import Vervis.Federation.Auth
 import Vervis.Foundation
 import Vervis.Model
 import Vervis.Model.Ident
+import Vervis.Recipient
 import Vervis.Secure
 import Vervis.Settings
 import Vervis.Ticket
@@ -116,8 +125,115 @@ getPersonR personHash = do
 getPersonInboxR :: KeyHashid Person -> Handler TypedContent
 getPersonInboxR = getInbox PersonInboxR personActor
 
-postPersonInboxR :: KeyHashid Person -> Handler TypedContent
-postPersonInboxR _ = error "Temporarily disabled"
+parseAuthenticatedLocalActivityURI
+    :: (MonadSite m, YesodHashids (SiteEnv m))
+    => LocalActorBy Key -> Maybe LocalURI -> ExceptT Text m OutboxItemId
+parseAuthenticatedLocalActivityURI author maybeActivityURI = do
+    luAct <- fromMaybeE maybeActivityURI "No 'id'"
+    (actorByKey, _, outboxItemID) <- parseLocalActivityURI luAct
+    unless (actorByKey == author) $
+        throwE "'actor' actor and 'id' actor mismatch"
+    return outboxItemID
+
+verifyLocalActivityExistsInDB
+    :: MonadIO m
+    => LocalActorBy Key
+    -> OutboxItemId
+    -> ExceptT Text (ReaderT SqlBackend m) ()
+verifyLocalActivityExistsInDB actorByKey outboxItemID = do
+    outboxID <- outboxItemOutbox <$> getE outboxItemID "No such OutboxItemId in DB"
+    itemActorID <- do
+        maybeActorID <-
+            lift $ getKeyBy $ UniqueActorOutbox outboxID
+        fromMaybeE maybeActorID "Outbox item's outbox doesn't belong to any Actor"
+    itemActorByKey <- lift $ getLocalActor' itemActorID
+    unless (itemActorByKey == actorByKey) $
+        throwE "Actor-in-URI and Actor-owning-the-outbox-item-in-DB mismatch"
+
+insertActivityToInbox
+    :: MonadIO m => ActorId -> OutboxItemId -> ReaderT SqlBackend m Bool
+insertActivityToInbox recipActorID outboxItemID = do
+    inboxID <- actorInbox <$> getJust recipActorID
+    inboxItemID <- insert $ InboxItem True
+    maybeItem <- insertUnique $ InboxItemLocal inboxID outboxItemID inboxItemID
+    case maybeItem of
+        Nothing -> do
+            delete inboxItemID
+            return False
+        Just _ -> return True
+
+postPersonInboxR :: KeyHashid Person -> Handler ()
+postPersonInboxR recipPersonHash = postInbox handle
+    where
+    handle
+        :: UTCTime
+        -> ActivityAuthentication
+        -> ActivityBody
+        -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
+
+    handle _ (ActivityAuthLocal authorByKey) body = (,Nothing) <$> do
+        outboxItemID <-
+            parseAuthenticatedLocalActivityURI
+                authorByKey
+                (AP.activityId $ actbActivity body)
+        recipPersonID <- decodeKeyHashid404 recipPersonHash
+        runDBExcept $ do
+            recipPerson <- lift $ get404 recipPersonID
+            verifyLocalActivityExistsInDB authorByKey outboxItemID
+            if LocalActorPerson recipPersonID == authorByKey
+                then return "Received activity authored by self, ignoring"
+                else lift $ do
+                    inserted <- insertActivityToInbox (personActor recipPerson) outboxItemID
+                    return $
+                        if inserted
+                            then "Activity inserted to recipient's inbox"
+                            else "Activity already exists in recipient's inbox"
+
+    handle now (ActivityAuthRemote author) body = do
+        luActivity <-
+            fromMaybeE (AP.activityId $ actbActivity body) "Activity without 'id'"
+        localRecips <- do
+            mrecips <- parseAudience $ AP.activityAudience $ actbActivity body
+            paudLocalRecips <$> fromMaybeE mrecips "Activity with no recipients"
+        msig <- checkForwarding $ LocalActorPerson recipPersonHash
+        let mfwd = (localRecips,) <$> msig
+        case AP.activitySpecific $ actbActivity body of
+            {-
+            AcceptActivity accept ->
+                (,Nothing) <$> sharerAcceptF shrRecip now author body mfwd luActivity accept
+            AddActivity (AP.Add obj target) ->
+                case obj of
+                    Right (AddBundle patches) ->
+                        sharerAddBundleF now shrRecip author body mfwd luActivity patches target
+                    _ -> return ("Unsupported add object type for sharers", Nothing)
+            CreateActivity (Create obj mtarget) ->
+                case obj of
+                    CreateNote _ note ->
+                        (,Nothing) <$> sharerCreateNoteF now shrRecip author body mfwd luActivity note
+                    CreateTicket _ ticket ->
+                        (,Nothing) <$> sharerCreateTicketF now shrRecip author body mfwd luActivity ticket mtarget
+                    _ -> return ("Unsupported create object type for sharers", Nothing)
+            FollowActivity follow ->
+                (,Nothing) <$> sharerFollowF shrRecip now author body mfwd luActivity follow
+            -}
+            {-
+            OfferActivity (Offer obj target) ->
+                case obj of
+                    OfferTicket ticket ->
+                        (,Nothing) <$> sharerOfferTicketF now shrRecip author body mfwd luActivity ticket target
+                    OfferDep dep ->
+                        sharerOfferDepF now shrRecip author body mfwd luActivity dep target
+                    _ -> return ("Unsupported offer object type for sharers", Nothing)
+            PushActivity push ->
+                (,Nothing) <$> sharerPushF shrRecip now author body mfwd luActivity push
+            RejectActivity reject ->
+                (,Nothing) <$> sharerRejectF shrRecip now author body mfwd luActivity reject
+            ResolveActivity resolve ->
+                (,Nothing) <$> sharerResolveF now shrRecip author body mfwd luActivity resolve
+            UndoActivity undo ->
+                (,Nothing) <$> sharerUndoF shrRecip now author body mfwd luActivity undo
+            -}
+            _ -> return ("Unsupported activity type for Person", Nothing)
 
 getPersonOutboxR :: KeyHashid Person -> Handler TypedContent
 getPersonOutboxR = getOutbox PersonOutboxR personActor

vervis.cabal

@@ -134,6 +134,8 @@ library
                        Vervis.Colour
                        Vervis.Content
                        Vervis.Darcs
+                       Vervis.Data.Actor
+                       Vervis.Data.Collab
                        Vervis.Delivery
                        Vervis.Discussion
                        Vervis.Federation