diff --git a/src/Vervis/Federation.hs b/src/Vervis/Federation.hs index d5a0aae..5aa1d5c 100644 --- a/src/Vervis/Federation.hs +++ b/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 diff --git a/src/Vervis/Handler/Inbox.hs b/src/Vervis/Handler/Inbox.hs index 305f0be..e908cb8 100644 --- a/src/Vervis/Handler/Inbox.hs +++ b/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