In sharer inbox, accept forwarded activities, including ones of local users

src/Vervis/Federation.hs

@@ -100,20 +100,20 @@ import Vervis.RemoteActorStore
 import Vervis.Settings
 
 data ActivityDetail = ActivityDetail
-    { _actdAuthorURI :: FedURI
+    { actdAuthorURI :: FedURI
-    , _actdInstance  :: InstanceId
+    , actdInstance  :: InstanceId
-    , _actdAuthorId  :: RemoteActorId
+    -- , actdAuthorId  :: RemoteActorId
-    , _actdRawBody   :: BL.ByteString
+    -- , actdRawBody   :: BL.ByteString
-    , _actdSignKey   :: KeyId
+    -- , actdSignKey   :: KeyId
-    , _actdDigest    :: Digest SHA256
+    -- , actdDigest    :: Digest SHA256
     }
 
-verifyActorSig :: Verification -> ExceptT String Handler ActivityDetail
+parseKeyId (KeyId k) =
-verifyActorSig (Verification malgo (KeyId keyid) input (Signature signature)) = do
+    case fmap f2l . parseFedURI =<< (first displayException . decodeUtf8') k of
-    (host, luKey) <- f2l <$> parseKeyId keyid
+        Left e -> throwE $ "keyId isn't a valid FedURI: " ++ e
-    checkHost host
+        Right u -> return u
-    (body, digest) <- verifyBodyDigest
+
-    mluActorHeader <- getActorHeader host
+verifyActorSig' malgo keyid input (Signature signature) host luKey mluActorHeader = do
     manager <- getsYesod appHttpManager
     (inboxOrVkid, vkd) <- do
         ments <- lift $ runDB $ do
@@ -192,44 +192,14 @@ verifyActorSig (Verification malgo (KeyId keyid) input (Signature signature)) =
                         else errSig2
 
     return ActivityDetail
-        { _actdAuthorURI = l2f host $ vkdActorId vkd
+        { actdAuthorURI = l2f host $ vkdActorId vkd
-        , _actdInstance  = iid
+        , actdInstance  = iid
-        , _actdAuthorId  = rsid
+        -- , actdAuthorId  = rsid
-        , _actdRawBody   = body
+        -- , actdRawBody   = body
-        , _actdSignKey   = KeyId keyid
+        -- , actdSignKey   = keyid
-        , _actdDigest    = digest
+        -- , actdDigest    = digest
         }
     where
-    parseKeyId k =
-        case parseFedURI =<< (first displayException . decodeUtf8') k of
-            Left e -> throwE $ "keyId in Sig header isn't a valid FedURI: " ++ e
-            Right u -> return u
-    checkHost h = do
-        home <- getsYesod $ appInstanceHost . appSettings
-        when (h == home) $
-            throwE "Received HTTP signed request from the instance's host"
-    verifyBodyDigest = do
-        req <- waiRequest
-        let headers = W.requestHeaders req
-        digest <- case parseHttpBodyDigest SHA256 "SHA-256" headers of
-            Left s -> throwE $ "Parsing digest header failed: " ++ s
-            Right d -> return d
-        (digest', body) <- liftIO $ hashHttpBody SHA256 (W.requestBody req)
-        unless (digest == digest') $
-            throwE "Body digest verification failed"
-        return (body, digest)
-    getActorHeader host = do
-        bs <- lookupHeaders hActivityPubActor
-        case bs of
-            [] -> return Nothing
-            [b] -> fmap Just . ExceptT . pure $ do
-                t <- first displayException $ decodeUtf8' b
-                (h, lu) <- f2l <$> parseFedURI t
-                if h == host
-                    then Right ()
-                    else Left "Key and actor have different hosts"
-                Right lu
-            _ -> throwE "Multiple ActivityPub-Actor headers"
     fetched2vkd uk (Fetched k mexp ua uinb s) =
         ( Left uinb
         , VerifKeyDetail
@@ -244,10 +214,78 @@ verifyActorSig (Verification malgo (KeyId keyid) input (Signature signature)) =
         update vkid [VerifKeyExpires =. vkdExpires vkd, VerifKeyPublic =. vkdKey vkd]
     withHostLock' h = ExceptT . withHostLock h . runExceptT
 
+verifyActorSig :: Verification -> ExceptT String Handler ActivityDetail
+verifyActorSig (Verification malgo keyid input signature) = do
+    (host, luKey) <- parseKeyId keyid
+    checkHost host
+    mluActorHeader <- getActorHeader host
+    verifyActorSig' malgo keyid input signature host luKey mluActorHeader
+    where
+    checkHost h = do
+        home <- getsYesod $ appInstanceHost . appSettings
+        when (h == home) $
+            throwE "Received HTTP signed request from the instance's host"
+    getActorHeader host = do
+        bs <- lookupHeaders hActivityPubActor
+        case bs of
+            [] -> return Nothing
+            [b] -> fmap Just . ExceptT . pure $ do
+                t <- first displayException $ decodeUtf8' b
+                (h, lu) <- f2l <$> parseFedURI t
+                if h == host
+                    then Right ()
+                    else Left "Key and actor have different hosts"
+                Right lu
+            _ -> throwE "Multiple ActivityPub-Actor headers"
+
+verifySelfSig :: LocalURI -> LocalURI -> ByteString -> Signature -> ExceptT String Handler PersonId
+verifySelfSig luAuthor luKey input (Signature sig) = do
+    shrAuthor <- do
+        route <-
+            case decodeRouteLocal luAuthor of
+                Nothing -> throwE "Local author ID isn't a valid route"
+                Just r -> return r
+        case route of
+            SharerR shr -> return shr
+            _ -> throwE "Local author ID isn't a user route"
+    akey <- do
+        route <-
+            case decodeRouteLocal luKey of
+                Nothing -> throwE "Local key ID isn't a valid route"
+                Just r -> return r
+        (akey1, akey2, _) <- liftIO . readTVarIO =<< getsYesod appActorKeys
+        case route of
+            ActorKey1R -> return akey1
+            ActorKey2R -> return akey2
+            _ -> throwE "Local key ID isn't an actor key route"
+    valid <-
+        ExceptT . pure $ verifySignature (actorKeyPublicBin akey) input sig
+    unless valid $
+        throwE "Self sig verification says not valid"
+    ExceptT $ runDB $ do
+        mpid <- runMaybeT $ do
+            sid <- MaybeT $ getKeyBy $ UniqueSharer shrAuthor
+            MaybeT $ getKeyBy $ UniquePersonIdent sid
+        return $
+            case mpid of
+                Nothing -> Left "Local author: No such user"
+                Just pid -> Right pid
+
+verifyForwardedSig :: Text -> LocalURI -> Verification -> ExceptT String Handler (Either PersonId ActivityDetail)
+verifyForwardedSig hAuthor luAuthor (Verification malgo keyid input signature) = do
+    (hKey, luKey) <- parseKeyId keyid
+    unless (hAuthor == hKey) $
+        throwE "Author and forwarded sig key on different hosts"
+    local <- hostIsLocal hKey
+    if local
+        then Left <$> verifySelfSig luAuthor luKey input signature
+        else Right <$> verifyActorSig' malgo keyid input signature hKey luKey (Just luAuthor)
+
 authenticateActivity
     :: UTCTime
-    -> ExceptT Text Handler (InstanceId, Object, Activity)
+    -> ExceptT Text Handler (Either PersonId InstanceId, Object, Activity)
 authenticateActivity now = do
+    (ad, wv) <- do
         verifyContentType
         proof <- withExceptT (T.pack . displayException) $ ExceptT $ do
             timeLimit <- getsYesod $ appHttpSigTimeLimit . appSettings
@@ -258,25 +296,38 @@ authenticateActivity now = do
                         toSeconds = toTimeUnit
                     in  fromIntegral $ toSeconds timeLimit
             prepareToVerifyHttpSig requires wants seconds now
-    ActivityDetail uSender iid _raid body _keyid _digest <-
+        (detail, body) <-
-        withExceptT T.pack $ verifyActorSig proof
+            withExceptT T.pack $
-    WithValue raw (Doc hActivity activity) <-
+                (,) <$> verifyActorSig proof
+                    <*> verifyBodyDigest
+        wvdoc <-
             case eitherDecode' body of
                 Left s -> throwE $ "Parsing activity failed: " <> T.pack s
                 Right wv -> return wv
-    let (hSender, luSender) = f2l uSender
+        return (detail, wvdoc)
-    unless (hSender == hActivity) $
+    let ActivityDetail uSender iid = ad
-        throwE $ T.concat
+        WithValue raw (Doc hActivity activity) = wv
-            [ "Activity host <", hActivity
+        (hSender, luSender) = f2l uSender
-            , "> doesn't match signature key host <", hSender, ">"
+    id_ <-
-            ]
+        if hSender == hActivity
+            then do
                 unless (activityActor activity == luSender) $
                     throwE $ T.concat
                         [ "Activity's actor <"
                         , renderFedURI $ l2f hActivity $ activityActor activity
-            , "> != Signature key's actor <", renderFedURI uSender, ">"
+                        , "> != Signature key's actor <", renderFedURI uSender
+                        , ">"
                         ]
-    return (iid, raw, activity)
+                return $ Right iid
+            else do
+                mi <- checkForward uSender hActivity (activityActor activity)
+                case mi of
+                    Nothing -> throwE $ T.concat
+                        [ "Activity host <", hActivity
+                        , "> doesn't match signature key host <", hSender, ">"
+                        ]
+                    Just i -> return i
+    return (id_, raw, activity)
     where
     verifyContentType = do
         ctypes <- lookupHeaders "Content-Type"
@@ -295,6 +346,39 @@ authenticateActivity now = do
         typeAS2 =
             "application/ld+json; \
             \profile=\"https://www.w3.org/ns/activitystreams\""
+    verifyBodyDigest = do
+        req <- waiRequest
+        let headers = W.requestHeaders req
+        digest <- case parseHttpBodyDigest SHA256 "SHA-256" headers of
+            Left s -> throwE $ "Parsing digest header failed: " ++ s
+            Right d -> return d
+        (digest', body) <- liftIO $ hashHttpBody SHA256 (W.requestBody req)
+        unless (digest == digest') $
+            throwE "Body digest verification failed"
+        return body
+    checkForward uSender hAuthor luAuthor = do
+        let hSig = hForwardedSignature
+        msig <- lookupHeader hSig
+        for msig $ \ _ -> do
+            uForwarder <- parseForwarderHeader
+            unless (uForwarder == uSender) $
+                throwE "Signed forwarder doesn't match the sender"
+            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
+            where
+            parseForwarderHeader = do
+                fwds <- lookupHeaders hActivityPubForwarder
+                fwd <-
+                    case fwds of
+                        [] -> throwE "ActivityPub-Forwarder header missing"
+                        [x] -> return x
+                        _ -> throwE "Multiple ActivityPub-Forwarder"
+                case parseFedURI =<< (first displayException . decodeUtf8') fwd of
+                    Left e -> throwE $ "ActivityPub-Forwarder isn't a valid FedURI: " <> T.pack e
+                    Right u -> return u
 
 hostIsLocal :: (MonadHandler m, HandlerSite m ~ App) => Text -> m Bool
 hostIsLocal h = getsYesod $ (== h) . appInstanceHost . appSettings
@@ -416,11 +500,42 @@ getLocalParentMessageId did shr lmid = do
 handleSharerInbox
     :: UTCTime
     -> ShrIdent
-    -> InstanceId
+    -> Either PersonId InstanceId
     -> Object
     -> Activity
     -> ExceptT Text Handler Text
-handleSharerInbox now shrRecip iidSender raw activity =
+handleSharerInbox _now shrRecip (Left pidAuthor) _raw activity = do
+    (shrActivity, obid) <- do
+        route <-
+            case decodeRouteLocal $ activityId activity of
+                Nothing -> throwE "Local activity: Not a valid route"
+                Just r -> return r
+        case route of
+            OutboxItemR shr obkhid ->
+                (shr,) <$> decodeKeyHashidE obkhid "Local activity: ID is invalid hashid"
+            _ -> throwE "Local activity: Not an activity route"
+    runDBExcept $ do
+        pidRecip <- lift $ do
+            sid <- getKeyBy404 $ UniqueSharer shrRecip
+            getKeyBy404 $ UniquePersonIdent sid
+        mob <- lift $ get obid
+        ob <- fromMaybeE mob "Local activity: No such ID in DB"
+        let pidOutbox = outboxItemPerson ob
+        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 do
+                miblid <- lift $ insertUnique $ InboxItemLocal pidRecip obid
+                let recip = shr2text shrRecip
+                return $ case miblid of
+                    Nothing -> "Activity already exists in inbox of /s/" <> recip
+                    Just _ -> "Activity inserted to inbox of /s/" <> recip
+handleSharerInbox now shrRecip (Right iidSender) raw activity =
     case activitySpecific activity of
         CreateActivity (Create note) -> handleNote note
         _ -> return "Unsupported activity type"
@@ -558,14 +673,6 @@ handleProjectInbox now shrRecip prjRecip iidSender hSender raidSender raw activi
                             -> Just LocalTicketTeam
                     _ -> Nothing
         recip = T.concat ["/s/", shr2text shrRecip, "/p/", prj2text prjRecip]
-        runDBExcept action = do
-            result <-
-                lift $ try $ runDB $ either abort return =<< runExceptT action
-            case result of
-                Left (FedError t) -> throwE t
-                Right r -> return r
-            where
-            abort = liftIO . throwIO . FedError
         getContextAndParent num mparent = do
             mt <- lift $ do
                 sid <- getKeyBy404 $ UniqueSharer shrRecip
@@ -703,6 +810,15 @@ newtype FedError = FedError Text deriving Show
 
 instance Exception FedError
 
+runDBExcept action = do
+    result <-
+        lift $ try $ runDB $ either abort return =<< runExceptT action
+    case result of
+        Left (FedError t) -> throwE t
+        Right r -> return r
+    where
+    abort = liftIO . throwIO . FedError
+
 deliverHttp
     :: (MonadSite m, SiteEnv m ~ App)
     => Doc Activity

src/Vervis/Handler/Inbox.hs

@@ -141,8 +141,8 @@ postSharerInboxR shrRecip = do
     contentTypes <- lookupHeaders "Content-Type"
     now <- liftIO getCurrentTime
     result <- runExceptT $ do
-        (iid, raw, activity) <- authenticateActivity now
+        (id_, raw, activity) <- authenticateActivity now
-        (raw,) <$> handleSharerInbox now shrRecip iid raw activity
+        (raw,) <$> handleSharerInbox now shrRecip id_ raw activity
     recordActivity now result contentTypes
     case result of
         Left _ -> sendResponseStatus badRequest400 ()

src/Web/ActivityPub.hs

@@ -50,6 +50,9 @@ module Web.ActivityPub
     , APGetError (..)
     , httpGetAP
     , APPostError (..)
+    , hActivityPubForwarder
+    , hForwardingSignature
+    , hForwardedSignature
     , httpPostAP
     , Fetched (..)
     , fetchAPID