diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index 77c65c0..5b7c58b 100644 --- a/src/Vervis/Foundation.hs +++ b/src/Vervis/Foundation.hs @@ -24,6 +24,7 @@ import Control.Monad.STM (atomically) import Control.Monad.Trans.Except import Control.Monad.Trans.Maybe import Crypto.Error (CryptoFailable (..)) +import Crypto.Hash.Algorithms import Data.Char import Data.Either (isRight) import Data.HashMap.Strict (HashMap) @@ -35,9 +36,10 @@ import Data.Time.Units (Second, Minute, Day) import Database.Persist.Postgresql import Database.Persist.Sql (ConnectionPool, runSqlPool) import Graphics.SVGFonts.ReadFont (PreparedFont) -import Network.HTTP.Client +import Network.HTTP.Client (Manager, HasHttpManager (..)) import Network.HTTP.Types.Header (hHost) import Network.URI (URI, uriAuthority, uriFragment, uriRegName, parseURI) +import Network.Wai import Text.Shakespeare.Text (textFile) import Text.Hamlet (hamletFile) --import Text.Jasmine (minifym) @@ -57,7 +59,8 @@ import qualified Yesod.Core.Unsafe as Unsafe import qualified Data.Text as T --import qualified Data.Text.Encoding as TE -import Network.HTTP.Signature hiding (Algorithm (..)) +import Network.HTTP.Digest +import Network.HTTP.Signature hiding (Algorithm (..), requestHeaders) import Yesod.Auth.Unverified import Yesod.Auth.Unverified.Creds import Yesod.HttpSignature (YesodHttpSig (..)) @@ -647,8 +650,8 @@ data ActorDetail = ActorDetail } instance YesodHttpSig App where - data HttpSigVerResult App = HttpSigVerResult (Either String ActorDetail) - httpSigVerRequiredHeaders = const [hRequestTarget, hHost] + data HttpSigVerResult App = HttpSigVerResult (Either String (ActorDetail, BL.ByteString)) + httpSigVerRequiredHeaders = const [hRequestTarget, hHost, hDigest] httpSigVerWantedHeaders = const [hActivityPubActor] httpSigVerSeconds = fromIntegral . toSeconds . appHttpSigTimeLimit . appSettings @@ -658,6 +661,7 @@ instance YesodHttpSig App where httpVerifySig (Verification malgo (KeyId keyid) input (Signature signature)) = fmap HttpSigVerResult $ runExceptT $ do (host, luKey) <- f2l <$> parseKeyId keyid checkHost host + body <- verifyBodyDigest mluActorHeader <- getActorHeader host manager <- getsYesod appHttpManager (inboxOrVkid, vkd) <- do @@ -736,11 +740,14 @@ instance YesodHttpSig App where return (iid, rsid) else errSig2 - return ActorDetail - { actorDetailId = l2f host $ vkdActorId vkd - , actorDetailInstance = iid - , actorDetailSharer = rsid - } + return + ( ActorDetail + { actorDetailId = l2f host $ vkdActorId vkd + , actorDetailInstance = iid + , actorDetailSharer = rsid + } + , body + ) where parseKeyId k = case parseFedURI =<< (first displayException . decodeUtf8') k of @@ -756,6 +763,16 @@ instance YesodHttpSig App where throwE "Received HTTP signed request from the instance's host" where isAsciiLetter c = isAsciiLower c || isAsciiUpper c + verifyBodyDigest = do + req <- waiRequest + let headers = 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 (requestBody req) + unless (digest == digest') $ + throwE "Body digest verification failed" + return body getActorHeader host = do bs <- lookupHeaders hActivityPubActor case bs of diff --git a/src/Vervis/Handler/Inbox.hs b/src/Vervis/Handler/Inbox.hs index 760ef5e..7f46edd 100644 --- a/src/Vervis/Handler/Inbox.hs +++ b/src/Vervis/Handler/Inbox.hs @@ -138,21 +138,24 @@ postSharerInboxR shrRecip = do federation <- getsYesod $ appFederation . appSettings unless federation badMethod contentTypes <- lookupHeaders "Content-Type" - body <- requireJsonBody now <- liftIO getCurrentTime - result <- go now contentTypes body - recordActivity now result contentTypes body + result <- go now contentTypes + recordActivity now result contentTypes case result of Left _ -> sendResponseStatus badRequest400 () Right _ -> return () where - go now ctypes (WithValue raw (Doc hActivity activity)) = runExceptT $ do + go now ctypes = runExceptT $ do verifyContentType HttpSigVerResult result <- ExceptT $ first (T.pack . displayException) <$> verifyRequestSignature now - ActorDetail uSender iid _raid <- ExceptT $ pure $ first T.pack result + (ActorDetail uSender iid _raid, body) <- ExceptT $ pure $ first T.pack result + 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 @@ -165,7 +168,7 @@ postSharerInboxR shrRecip = do , renderFedURI $ l2f hActivity $ activityActor activity , "> != Signature key's actor <", renderFedURI uSender, ">" ] - handleSharerInbox now shrRecip iid raw activity + (raw,) <$> handleSharerInbox now shrRecip iid raw activity where verifyContentType = case ctypes of @@ -183,12 +186,14 @@ postSharerInboxR shrRecip = do typeAS2 = "application/ld+json; \ \profile=\"https://www.w3.org/ns/activitystreams\"" - recordActivity now result contentTypes body = do + recordActivity now result contentTypes = do acts <- getsYesod appActivities liftIO $ atomically $ modifyTVar' acts $ \ vec -> - let msg = either id id result - formattedBody = encodePretty $ wvRaw body - item = ActivityReport now msg contentTypes formattedBody + 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' > 10 then V.init vec'