From 2a4dc345f4c1bbac1ce1b250cacf4f9f8393d01f Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Sat, 19 Jan 2019 04:21:56 +0000 Subject: [PATCH] Back to using the (updated) YesodHttpSig class --- src/Vervis/Foundation.hs | 120 ++++++++++++++++++------------------ src/Vervis/Handler/Inbox.hs | 79 ++---------------------- 2 files changed, 63 insertions(+), 136 deletions(-) diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index a95501e..98caeea 100644 --- a/src/Vervis/Foundation.hs +++ b/src/Vervis/Foundation.hs @@ -18,6 +18,7 @@ module Vervis.Foundation where import Prelude (init, last) import Control.Monad.Logger.CallStack (logWarn) +import Control.Monad.Trans.Except (ExceptT (ExceptT), runExceptT) import Control.Monad.Trans.Maybe import Crypto.Error (CryptoFailable (..)) import Crypto.PubKey.Ed25519 (publicKey, signature, verify) @@ -27,8 +28,8 @@ import Data.Time.Units (Second, Minute, Day) import Database.Persist.Sql (ConnectionPool, runSqlPool) import Graphics.SVGFonts.ReadFont (PreparedFont) import Network.HTTP.Client (Manager, HttpException, requestFromURI) -import Network.HTTP.Simple (httpJSONEither, getResponseBody) -import Network.URI (uriFragment, parseURI) +import Network.HTTP.Simple (httpJSONEither, getResponseBody, setRequestManager, addRequestHeader) +import Network.URI (URI (uriFragment), parseURI) import Text.Shakespeare.Text (textFile) import Text.Hamlet (hamletFile) --import Text.Jasmine (minifym) @@ -560,72 +561,69 @@ unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger -- https://github.com/yesodweb/yesod/wiki/Serve-static-files-from-a-separate-domain -- https://github.com/yesodweb/yesod/wiki/i18n-messages-in-the-scaffolding -{- instance YesodHttpSig App where - data HttpSigVerResult App = HttpSigVerResult Bool + data HttpSigVerResult App = HttpSigVerResult (Either String URI) httpSigVerHeaders = const [HeaderTarget, HeaderName "Host"] httpSigVerSeconds = fromIntegral . toSeconds . appHttpSigTimeLimit . appSettings where toSeconds :: TimeInterval -> Second toSeconds = toTimeUnit - httpVerifySig malgo (KeyId keyid) input (Signature sig) = - if algoSupported malgo - then case parseURI $ BC.unpack keyid of - Just u -> do - eres <- try $ httpJSONEither =<< requestFromURI u - case eres of - Left e -> do - logWarn $ "httpVerifySig got HTTP exception: " <> T.pack (displayException (e :: HttpException)) - -- return HttpSigVerKeyNotFound - return $ HttpSigVerResult False - Right r -> - case getResponseBody r of - Left e -> do - logWarn $ "httpVerifySig got JSON exception: " <> T.pack (displayException e) - -- return HttpSigVerKeyNotFound - return $ HttpSigVerResult False - Right actor -> do - let uActor = u { uriFragment = "" } - if uActor == actorId actor - then - let pkey = actorPublicKey actor - in if publicKeyId pkey == u && publicKeyOwner pkey == actorId actor - then case publicKeyAlgo pkey of - Just AlgorithmEd25519 -> - case publicKey $ pemContent $ publicKeyPem pkey of - CryptoPassed k -> - case signature sig of - CryptoPassed s -> - return $ if verify k input s - then -- HttpSigVerValid - HttpSigVerResult True - else -- HttpSigVerInvalid - HttpSigVerResult False - CryptoFailed e -> -- TODO handle - return $ HttpSigVerResult False - CryptoFailed e -> -- TODO handle - return $ HttpSigVerResult False - _ -> case malgo of - Nothing -> -- return HttpSigVerAlgoNotSupported - return $ HttpSigVerResult False - Just _ -> -- return HttpSigVerAlgoMismatch - return $ HttpSigVerResult False - else -- TODO handle the mismatch - return $ HttpSigVerResult False - else -- TODO actor id doesn't match URL we accessed! - return $ HttpSigVerResult False - Nothing -> -- return HttpSigVerKeyNotFound - return $ HttpSigVerResult False - else -- return HttpSigVerAlgoNotSupported - return $ HttpSigVerResult False - where - algoSupported Nothing = True - algoSupported (Just a) = - case a of - S.AlgorithmEd25519 -> True - S.AlgorithmOther _ -> False --} + httpVerifySig (Verification malgo (KeyId keyid) input (Signature sig)) = fmap HttpSigVerResult $ runExceptT $ do + ExceptT . pure $ case malgo of + Nothing -> Right () + Just algo -> + case algo of + S.AlgorithmEd25519 -> Right () + S.AlgorithmOther _ -> Left "Unsupported algo in Sig header" + u <- ExceptT . pure $ case parseURI $ BC.unpack keyid of + Nothing -> Left "keyId in Sig header isn't a valid absolute URI" + Just uri -> Right uri + manager <- getsYesod appHttpManager + response <- + ExceptT $ first (displayException :: HttpException -> String) <$> + (try $ + httpJSONEither . + addRequestHeader "Accept" "application/ld+json; profile=\"https://www.w3.org/ns/activitystreams\"" . + setRequestManager manager + =<< requestFromURI u + ) + ExceptT . pure $ do + actor <- first displayException $ getResponseBody response + let uActor = u { uriFragment = "" } + if uActor == actorId actor + then Right () + else Left "Actor ID doesn't match the keyid URI we fetched" + let pkey = actorPublicKey actor + if publicKeyId pkey == u + then Right () + else Left "Actor's publicKey's ID doesn't match the keyid URI" + if publicKeyOwner pkey == actorId actor + then Right () + else Left "Actor's publicKey's owner doesn't match the actor's ID" + case publicKeyAlgo pkey of + Nothing -> + Left $ + case malgo of + Nothing -> "Algo not given in Sig nor actor" + Just _ -> "Algo mismatch, Ed25519 in Sig but none in actor" + Just algo -> + case algo of + AlgorithmEd25519 -> Right () + AlgorithmOther _ -> + Left $ + case malgo of + Nothing -> "No algo in Sig, unsupported algo in actor" + Just _ -> "Algo mismatch, Ed25519 in Sig but unsupported algo in actor" + key <- case publicKey $ pemContent $ publicKeyPem pkey of + CryptoPassed k -> Right k + CryptoFailed e -> Left "Parsing Ed25519 public key failed" + signature <- case signature sig of + CryptoPassed s -> Right s + CryptoFailed e -> Left "Parsing Ed25519 signature failed" + if verify key input signature + then Right uActor + else Left "Ed25519 sig verification says not valid" instance YesodBreadcrumbs App where breadcrumb route = return $ case route of diff --git a/src/Vervis/Handler/Inbox.hs b/src/Vervis/Handler/Inbox.hs index fe97ec1..2294ae5 100644 --- a/src/Vervis/Handler/Inbox.hs +++ b/src/Vervis/Handler/Inbox.hs @@ -56,11 +56,12 @@ import qualified Data.Vector as V (length, cons, init) import qualified Network.Wai as W (requestMethod, rawPathInfo, requestHeaders) import Network.HTTP.Signature hiding (Algorithm (..)) +import Yesod.HttpSignature (verifyRequestSignature) import qualified Network.HTTP.Signature as S (Algorithm (..)) import Vervis.ActivityPub -import Vervis.Foundation (App (..), Handler) +import Vervis.Foundation (App (..), HttpSigVerResult (..), Handler) import Vervis.Settings (AppSettings (appHttpSigTimeLimit)) getInboxR :: Handler Html @@ -127,79 +128,6 @@ postInboxR = do Left _ -> notAuthenticated where liftE = ExceptT . pure - verifyActivity :: UTCTime -> ExceptT String Handler URI - verifyActivity now = do - site <- getYesod - wr <- waiRequest - let request = Request - { requestMethod = CI.mk $ W.requestMethod wr - , requestPath = W.rawPathInfo wr - , requestHeaders = W.requestHeaders wr - } - toSeconds :: TimeInterval -> Second - toSeconds = toTimeUnit - (malgo, KeyId keyid, input, Signature sig) <- - liftE $ - first show $ - prepareToVerify - [HeaderTarget, HeaderName "Host"] - (fromIntegral . toSeconds . appHttpSigTimeLimit . appSettings $ site) - now - request - liftE $ case malgo of - Nothing -> Right () - Just algo -> - case algo of - S.AlgorithmEd25519 -> Right () - S.AlgorithmOther _ -> Left "Unsupported algo in Sig header" - u <- liftE $ case parseURI $ BC.unpack keyid of - Nothing -> Left "keyId in Sig header isn't a valid absolute URI" - Just uri -> Right uri - manager <- getsYesod appHttpManager - response <- - ExceptT $ first (displayException :: HttpException -> String) <$> - (try $ - httpJSONEither . - addRequestHeader "Accept" "application/ld+json; profile=\"https://www.w3.org/ns/activitystreams\"" . - setRequestManager manager - =<< requestFromURI u - ) - liftE $ do - actor <- first displayException $ getResponseBody response - let uActor = u { uriFragment = "" } - if uActor == actorId actor - then Right () - else Left "Actor ID doesn't match the keyid URI we fetched" - let pkey = actorPublicKey actor - if publicKeyId pkey == u - then Right () - else Left "Actor's publicKey's ID doesn't match the keyid URI" - if publicKeyOwner pkey == actorId actor - then Right () - else Left "Actor's publicKey's owner doesn't match the actor's ID" - case publicKeyAlgo pkey of - Nothing -> - Left $ - case malgo of - Nothing -> "Algo not given in Sig nor actor" - Just _ -> "Algo mismatch, Ed25519 in Sig but none in actor" - Just algo -> - case algo of - AlgorithmEd25519 -> Right () - AlgorithmOther _ -> - Left $ - case malgo of - Nothing -> "No algo in Sig, unsupported algo in actor" - Just _ -> "Algo mismatch, Ed25519 in Sig but unsupported algo in actor" - key <- case publicKey $ pemContent $ publicKeyPem pkey of - CryptoPassed k -> Right k - CryptoFailed e -> Left "Parsing Ed25519 public key failed" - signature <- case signature sig of - CryptoPassed s -> Right s - CryptoFailed e -> Left "Parsing Ed25519 signature failed" - if verify key input signature - then Right uActor - else Left "Ed25519 sig verification says not valid" getActivity :: UTCTime -> ExceptT String Handler (ContentType, HashMap Text Value) getActivity now = do contentType <- do @@ -211,7 +139,8 @@ postInboxR = do "application/ld+json; profile=\"https://www.w3.org/ns/activitystreams\"" -> Right x _ -> Left "Unknown Content-Type" _ -> Left "More than one Content-Type given" - uActor <- verifyActivity now + HttpSigVerResult result <- ExceptT . fmap (first displayException) $ verifyRequestSignature now + uActor <- liftE result o <- requireJsonBody activityActor <- liftE $