When receiving activity to inbox, verify the body digest
This patch does a small simple change, however at the cost of the request body not being available for display in the latest activity list, unless processing succeeds. I'll fix this situation in a separate patch.
This commit is contained in:
fr33domlover
parent
57374ec816
commit
d24710c46a
2 changed files with 41 additions and 19 deletions
|
|
@ -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
|
||||
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
|
||||
|
|
|
|||
|
|
@ -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'
|
||||
|
|
|
|||
Loading…
Reference in a new issue