forge/Vervis
1
0
Fork 0
Code Pull requests Activity

When receiving activity to inbox, verify the body digest

Browse source 
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 2019-04-25 18:05:02 +00:00
parent 57374ec816
commit d24710c46a
2 changed files with 41 additions and 19 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

35
src/Vervis/Foundation.hs
View file

@ -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

25
src/Vervis/Handler/Inbox.hs
View file

@ -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'