Plug the project inbox handler code into the actual POST handler function

src/Vervis/Federation.hs

@@ -14,7 +14,8 @@
  -}
 
 module Vervis.Federation
-    ( authenticateActivity
+    ( ActivityDetail (..)
+    , authenticateActivity
     , handleSharerInbox
     , handleProjectInbox
     , fixRunningDeliveries
@@ -103,7 +104,7 @@ import Vervis.Settings
 data ActivityDetail = ActivityDetail
     { actdAuthorURI :: FedURI
     , actdInstance  :: InstanceId
-    -- , actdAuthorId  :: RemoteActorId
+    , actdAuthorId  :: RemoteActorId
     -- , actdRawBody   :: BL.ByteString
     -- , actdSignKey   :: KeyId
     -- , actdDigest    :: Digest SHA256
@@ -114,7 +115,7 @@ parseKeyId (KeyId k) =
         Left e -> throwE $ "keyId isn't a valid FedURI: " ++ e
         Right u -> return u
 
-verifyActorSig' malgo keyid input (Signature signature) host luKey mluActorHeader = do
+verifyActorSig' malgo input (Signature signature) host luKey mluActorHeader = do
     manager <- getsYesod appHttpManager
     (inboxOrVkid, vkd) <- do
         ments <- lift $ runDB $ do
@@ -195,7 +196,7 @@ verifyActorSig' malgo keyid input (Signature signature) host luKey mluActorHeade
     return ActivityDetail
         { actdAuthorURI = l2f host $ vkdActorId vkd
         , actdInstance  = iid
-        -- , actdAuthorId  = rsid
+        , actdAuthorId  = rsid
         -- , actdRawBody   = body
         -- , actdSignKey   = keyid
         -- , actdDigest    = digest
@@ -220,7 +221,7 @@ verifyActorSig (Verification malgo keyid input signature) = do
     (host, luKey) <- parseKeyId keyid
     checkHost host
     mluActorHeader <- getActorHeader host
-    verifyActorSig' malgo keyid input signature host luKey mluActorHeader
+    verifyActorSig' malgo input signature host luKey mluActorHeader
     where
     checkHost h = do
         home <- getsYesod $ appInstanceHost . appSettings
@@ -280,13 +281,13 @@ verifyForwardedSig hAuthor luAuthor (Verification malgo keyid input signature) =
     local <- hostIsLocal hKey
     if local
         then Left <$> verifySelfSig luAuthor luKey input signature
-        else Right <$> verifyActorSig' malgo keyid input signature hKey luKey (Just luAuthor)
+        else Right <$> verifyActorSig' malgo input signature hKey luKey (Just luAuthor)
 
 authenticateActivity
     :: UTCTime
-    -> ExceptT Text Handler (Either PersonId InstanceId, Object, Activity)
+    -> ExceptT Text Handler (Either PersonId ActivityDetail, BL.ByteString, Object, Activity)
 authenticateActivity now = do
-    (ad, wv) <- do
+    (ad, wv, body) <- do
         verifyContentType
         proof <- withExceptT (T.pack . displayException) $ ExceptT $ do
             timeLimit <- getsYesod $ appHttpSigTimeLimit . appSettings
@@ -305,9 +306,9 @@ authenticateActivity now = do
             case eitherDecode' body of
                 Left s -> throwE $ "Parsing activity failed: " <> T.pack s
                 Right wv -> return wv
-        return (detail, wvdoc)
-    let ActivityDetail uSender iid = ad
-        WithValue raw (Doc hActivity activity) = wv
+        return (detail, wvdoc, body)
+    let WithValue raw (Doc hActivity activity) = wv
+        uSender = actdAuthorURI ad
         (hSender, luSender) = f2l uSender
     id_ <-
         if hSender == hActivity
@@ -319,7 +320,7 @@ authenticateActivity now = do
                         , "> != Signature key's actor <", renderFedURI uSender
                         , ">"
                         ]
-                return $ Right iid
+                return $ Right ad
             else do
                 mi <- checkForward uSender hActivity (activityActor activity)
                 case mi of
@@ -328,7 +329,7 @@ authenticateActivity now = do
                         , "> doesn't match signature key host <", hSender, ">"
                         ]
                     Just i -> return i
-    return (id_, raw, activity)
+    return (id_, body, raw, activity)
     where
     verifyContentType = do
         ctypes <- lookupHeaders "Content-Type"
@@ -367,8 +368,7 @@ authenticateActivity now = do
             proof <- withExceptT (T.pack . displayException) $ ExceptT $
                 let requires = [hDigest, hActivityPubForwarder]
                 in  prepareToVerifyHttpSigWith hSig False requires [] Nothing
-            result <- withExceptT T.pack $ verifyForwardedSig hAuthor luAuthor proof
-            return $ second actdInstance result
+            withExceptT T.pack $ verifyForwardedSig hAuthor luAuthor proof
             where
             parseForwarderHeader = do
                 fwds <- lookupHeaders hActivityPubForwarder
@@ -1438,6 +1438,7 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished c
                 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
@@ -1452,6 +1453,7 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished c
         case id_ of
             Left pid -> lift $ insert_ $ InboxItemLocal pid obid
             Right _gid -> throwE "Local Note addresses a local group"
+    -}
 
     deliverRemoteDB
         :: Text

src/Vervis/Handler/Inbox.hs

@@ -141,29 +141,46 @@ postSharerInboxR shrRecip = do
     contentTypes <- lookupHeaders "Content-Type"
     now <- liftIO getCurrentTime
     result <- runExceptT $ do
-        (id_, raw, activity) <- authenticateActivity now
-        (raw,) <$> handleSharerInbox now shrRecip id_ raw activity
+        (id_, _body, raw, activity) <- authenticateActivity now
+        let id' = second actdInstance id_
+        (raw,) <$> handleSharerInbox now shrRecip id' raw activity
     recordActivity now result contentTypes
     case result of
         Left _ -> sendResponseStatus badRequest400 ()
         Right _ -> return ()
-    where
-    recordActivity now result contentTypes = do
-        macts <- getsYesod 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'
+
+recordActivity now result contentTypes = do
+    macts <- getsYesod 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'
 
 postProjectInboxR :: ShrIdent -> PrjIdent -> Handler ()
-postProjectInboxR _ _ = error "TODO implement postProjectInboxR"
+postProjectInboxR shrRecip prjRecip = do
+    federation <- getsYesod $ appFederation . appSettings
+    unless federation badMethod
+    contentTypes <- lookupHeaders "Content-Type"
+    now <- liftIO getCurrentTime
+    result <- runExceptT $ do
+        (id_, body, raw, activity) <- authenticateActivity now
+        ActivityDetail uAuthor iidAuthor raidAuthor <-
+            case id_ of
+                Left _pid -> throwE "Project inbox got local forwarded activity"
+                Right d -> return d
+        let hAuthor = furiHost uAuthor
+        (raw,) <$> handleProjectInbox now shrRecip prjRecip iidAuthor hAuthor raidAuthor body raw activity
+    recordActivity now result contentTypes
+    case result of
+        Left _ -> sendResponseStatus badRequest400 ()
+        Right _ -> return ()
 
 {-
 jsonField :: (FromJSON a, ToJSON a) => Field Handler a