forge/Vervis
1
0
Fork 0
Code Pull requests Activity

Back to using the (updated) YesodHttpSig class

Browse source
This commit is contained in:
fr33domlover 2019-01-19 04:21:56 +00:00
parent 393cce0ede
commit 2a4dc345f4
2 changed files with 63 additions and 136 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

120
src/Vervis/Foundation.hs
View file

@ -18,6 +18,7 @@ module Vervis.Foundation where
import Prelude (init, last) import Prelude (init, last)
import Control.Monad.Logger.CallStack (logWarn) import Control.Monad.Logger.CallStack (logWarn)
import Control.Monad.Trans.Except (ExceptT (ExceptT), runExceptT)
import Control.Monad.Trans.Maybe import Control.Monad.Trans.Maybe
import Crypto.Error (CryptoFailable (..)) import Crypto.Error (CryptoFailable (..))
import Crypto.PubKey.Ed25519 (publicKey, signature, verify) 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 Database.Persist.Sql (ConnectionPool, runSqlPool)
import Graphics.SVGFonts.ReadFont (PreparedFont) import Graphics.SVGFonts.ReadFont (PreparedFont)
import Network.HTTP.Client (Manager, HttpException, requestFromURI) import Network.HTTP.Client (Manager, HttpException, requestFromURI)
import Network.HTTP.Simple (httpJSONEither, getResponseBody) import Network.HTTP.Simple (httpJSONEither, getResponseBody, setRequestManager, addRequestHeader)
import Network.URI (uriFragment, parseURI) import Network.URI (URI (uriFragment), parseURI)
import Text.Shakespeare.Text (textFile) import Text.Shakespeare.Text (textFile)
import Text.Hamlet (hamletFile) import Text.Hamlet (hamletFile)
--import Text.Jasmine (minifym) --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/Serve-static-files-from-a-separate-domain
-- https://github.com/yesodweb/yesod/wiki/i18n-messages-in-the-scaffolding -- https://github.com/yesodweb/yesod/wiki/i18n-messages-in-the-scaffolding
{-
instance YesodHttpSig App where instance YesodHttpSig App where
data HttpSigVerResult App = HttpSigVerResult Bool data HttpSigVerResult App = HttpSigVerResult (Either String URI)
httpSigVerHeaders = const [HeaderTarget, HeaderName "Host"] httpSigVerHeaders = const [HeaderTarget, HeaderName "Host"]
httpSigVerSeconds = httpSigVerSeconds =
fromIntegral . toSeconds . appHttpSigTimeLimit . appSettings fromIntegral . toSeconds . appHttpSigTimeLimit . appSettings
where where
toSeconds :: TimeInterval -> Second toSeconds :: TimeInterval -> Second
toSeconds = toTimeUnit toSeconds = toTimeUnit
httpVerifySig malgo (KeyId keyid) input (Signature sig) = httpVerifySig (Verification malgo (KeyId keyid) input (Signature sig)) = fmap HttpSigVerResult $ runExceptT $ do
if algoSupported malgo ExceptT . pure $ case malgo of
then case parseURI $ BC.unpack keyid of Nothing -> Right ()
Just u -> do Just algo ->
eres <- try $ httpJSONEither =<< requestFromURI u case algo of
case eres of S.AlgorithmEd25519 -> Right ()
Left e -> do S.AlgorithmOther _ -> Left "Unsupported algo in Sig header"
logWarn $ "httpVerifySig got HTTP exception: " <> T.pack (displayException (e :: HttpException)) u <- ExceptT . pure $ case parseURI $ BC.unpack keyid of
-- return HttpSigVerKeyNotFound Nothing -> Left "keyId in Sig header isn't a valid absolute URI"
return $ HttpSigVerResult False Just uri -> Right uri
Right r -> manager <- getsYesod appHttpManager
case getResponseBody r of response <-
Left e -> do ExceptT $ first (displayException :: HttpException -> String) <$>
logWarn $ "httpVerifySig got JSON exception: " <> T.pack (displayException e) (try $
-- return HttpSigVerKeyNotFound httpJSONEither .
return $ HttpSigVerResult False addRequestHeader "Accept" "application/ld+json; profile=\"https://www.w3.org/ns/activitystreams\"" .
Right actor -> do setRequestManager manager
let uActor = u { uriFragment = "" } =<< requestFromURI u
if uActor == actorId actor )
then ExceptT . pure $ do
let pkey = actorPublicKey actor actor <- first displayException $ getResponseBody response
in if publicKeyId pkey == u && publicKeyOwner pkey == actorId actor let uActor = u { uriFragment = "" }
then case publicKeyAlgo pkey of if uActor == actorId actor
Just AlgorithmEd25519 -> then Right ()
case publicKey $ pemContent $ publicKeyPem pkey of else Left "Actor ID doesn't match the keyid URI we fetched"
CryptoPassed k -> let pkey = actorPublicKey actor
case signature sig of if publicKeyId pkey == u
CryptoPassed s -> then Right ()
return $ if verify k input s else Left "Actor's publicKey's ID doesn't match the keyid URI"
then -- HttpSigVerValid if publicKeyOwner pkey == actorId actor
HttpSigVerResult True then Right ()
else -- HttpSigVerInvalid else Left "Actor's publicKey's owner doesn't match the actor's ID"
HttpSigVerResult False case publicKeyAlgo pkey of
CryptoFailed e -> -- TODO handle Nothing ->
return $ HttpSigVerResult False Left $
CryptoFailed e -> -- TODO handle case malgo of
return $ HttpSigVerResult False Nothing -> "Algo not given in Sig nor actor"
_ -> case malgo of Just _ -> "Algo mismatch, Ed25519 in Sig but none in actor"
Nothing -> -- return HttpSigVerAlgoNotSupported Just algo ->
return $ HttpSigVerResult False case algo of
Just _ -> -- return HttpSigVerAlgoMismatch AlgorithmEd25519 -> Right ()
return $ HttpSigVerResult False AlgorithmOther _ ->
else -- TODO handle the mismatch Left $
return $ HttpSigVerResult False case malgo of
else -- TODO actor id doesn't match URL we accessed! Nothing -> "No algo in Sig, unsupported algo in actor"
return $ HttpSigVerResult False Just _ -> "Algo mismatch, Ed25519 in Sig but unsupported algo in actor"
Nothing -> -- return HttpSigVerKeyNotFound key <- case publicKey $ pemContent $ publicKeyPem pkey of
return $ HttpSigVerResult False CryptoPassed k -> Right k
else -- return HttpSigVerAlgoNotSupported CryptoFailed e -> Left "Parsing Ed25519 public key failed"
return $ HttpSigVerResult False signature <- case signature sig of
where CryptoPassed s -> Right s
algoSupported Nothing = True CryptoFailed e -> Left "Parsing Ed25519 signature failed"
algoSupported (Just a) = if verify key input signature
case a of then Right uActor
S.AlgorithmEd25519 -> True else Left "Ed25519 sig verification says not valid"
S.AlgorithmOther _ -> False
-}
instance YesodBreadcrumbs App where instance YesodBreadcrumbs App where
breadcrumb route = return $ case route of breadcrumb route = return $ case route of

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

@ -56,11 +56,12 @@ import qualified Data.Vector as V (length, cons, init)
import qualified Network.Wai as W (requestMethod, rawPathInfo, requestHeaders) import qualified Network.Wai as W (requestMethod, rawPathInfo, requestHeaders)
import Network.HTTP.Signature hiding (Algorithm (..)) import Network.HTTP.Signature hiding (Algorithm (..))
import Yesod.HttpSignature (verifyRequestSignature)
import qualified Network.HTTP.Signature as S (Algorithm (..)) import qualified Network.HTTP.Signature as S (Algorithm (..))
import Vervis.ActivityPub import Vervis.ActivityPub
import Vervis.Foundation (App (..), Handler) import Vervis.Foundation (App (..), HttpSigVerResult (..), Handler)
import Vervis.Settings (AppSettings (appHttpSigTimeLimit)) import Vervis.Settings (AppSettings (appHttpSigTimeLimit))
getInboxR :: Handler Html getInboxR :: Handler Html
@ -127,79 +128,6 @@ postInboxR = do
Left _ -> notAuthenticated Left _ -> notAuthenticated
where where
liftE = ExceptT . pure 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 :: UTCTime -> ExceptT String Handler (ContentType, HashMap Text Value)
getActivity now = do getActivity now = do
contentType <- do contentType <- do
@ -211,7 +139,8 @@ postInboxR = do
"application/ld+json; profile=\"https://www.w3.org/ns/activitystreams\"" -> Right x "application/ld+json; profile=\"https://www.w3.org/ns/activitystreams\"" -> Right x
_ -> Left "Unknown Content-Type" _ -> Left "Unknown Content-Type"
_ -> Left "More than one Content-Type given" _ -> Left "More than one Content-Type given"
uActor <- verifyActivity now HttpSigVerResult result <- ExceptT . fmap (first displayException) $ verifyRequestSignature now
uActor <- liftE result
o <- requireJsonBody o <- requireJsonBody
activityActor <- activityActor <-
liftE $ liftE $