diff --git a/src/Vervis/Federation.hs b/src/Vervis/Federation.hs index c0980c0..085580f 100644 --- a/src/Vervis/Federation.hs +++ b/src/Vervis/Federation.hs @@ -100,20 +100,20 @@ import Vervis.RemoteActorStore import Vervis.Settings data ActivityDetail = ActivityDetail - { _actdAuthorURI :: FedURI - , _actdInstance :: InstanceId - , _actdAuthorId :: RemoteActorId - , _actdRawBody :: BL.ByteString - , _actdSignKey :: KeyId - , _actdDigest :: Digest SHA256 + { actdAuthorURI :: FedURI + , actdInstance :: InstanceId + -- , actdAuthorId :: RemoteActorId + -- , actdRawBody :: BL.ByteString + -- , actdSignKey :: KeyId + -- , actdDigest :: Digest SHA256 } -verifyActorSig :: Verification -> ExceptT String Handler ActivityDetail -verifyActorSig (Verification malgo (KeyId keyid) input (Signature signature)) = do - (host, luKey) <- f2l <$> parseKeyId keyid - checkHost host - (body, digest) <- verifyBodyDigest - mluActorHeader <- getActorHeader host +parseKeyId (KeyId k) = + case fmap f2l . parseFedURI =<< (first displayException . decodeUtf8') k of + Left e -> throwE $ "keyId isn't a valid FedURI: " ++ e + Right u -> return u + +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 - , _actdInstance = iid - , _actdAuthorId = rsid - , _actdRawBody = body - , _actdSignKey = KeyId keyid - , _actdDigest = digest + { actdAuthorURI = l2f host $ vkdActorId vkd + , actdInstance = iid + -- , actdAuthorId = rsid + -- , actdRawBody = body + -- , actdSignKey = keyid + -- , 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,39 +214,120 @@ 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 - verifyContentType - proof <- withExceptT (T.pack . displayException) $ ExceptT $ do - timeLimit <- getsYesod $ appHttpSigTimeLimit . appSettings - let requires = [hRequestTarget, hHost, hDigest] - wants = [hActivityPubActor] - seconds = - let toSeconds :: TimeInterval -> Second - toSeconds = toTimeUnit - in fromIntegral $ toSeconds timeLimit - prepareToVerifyHttpSig requires wants seconds now - ActivityDetail uSender iid _raid body _keyid _digest <- - withExceptT T.pack $ verifyActorSig proof - WithValue raw (Doc hActivity activity) <- - case eitherDecode' body of - Left s -> throwE $ "Parsing activity failed: " <> T.pack s - Right wv -> return wv - let (hSender, luSender) = f2l uSender - unless (hSender == hActivity) $ - throwE $ T.concat - [ "Activity host <", hActivity - , "> doesn't match signature key host <", hSender, ">" - ] - unless (activityActor activity == luSender) $ - throwE $ T.concat - [ "Activity's actor <" - , renderFedURI $ l2f hActivity $ activityActor activity - , "> != Signature key's actor <", renderFedURI uSender, ">" - ] - return (iid, raw, activity) + (ad, wv) <- do + verifyContentType + proof <- withExceptT (T.pack . displayException) $ ExceptT $ do + timeLimit <- getsYesod $ appHttpSigTimeLimit . appSettings + let requires = [hRequestTarget, hHost, hDigest] + wants = [hActivityPubActor] + seconds = + let toSeconds :: TimeInterval -> Second + toSeconds = toTimeUnit + in fromIntegral $ toSeconds timeLimit + prepareToVerifyHttpSig requires wants seconds now + (detail, body) <- + withExceptT T.pack $ + (,) <$> verifyActorSig proof + <*> verifyBodyDigest + wvdoc <- + 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 + (hSender, luSender) = f2l uSender + 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 + , ">" + ] + 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 diff --git a/src/Vervis/Handler/Inbox.hs b/src/Vervis/Handler/Inbox.hs index 780cda8..305f0be 100644 --- a/src/Vervis/Handler/Inbox.hs +++ b/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 - (raw,) <$> handleSharerInbox now shrRecip iid raw activity + (id_, raw, activity) <- authenticateActivity now + (raw,) <$> handleSharerInbox now shrRecip id_ raw activity recordActivity now result contentTypes case result of Left _ -> sendResponseStatus badRequest400 () diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index e04732f..3fab2e2 100644 --- a/src/Web/ActivityPub.hs +++ b/src/Web/ActivityPub.hs @@ -50,6 +50,9 @@ module Web.ActivityPub , APGetError (..) , httpGetAP , APPostError (..) + , hActivityPubForwarder + , hForwardingSignature + , hForwardedSignature , httpPostAP , Fetched (..) , fetchAPID