mirror of
https://code.sup39.dev/repos/Wqawg
synced 2024-12-28 23:54:51 +09:00
Back to using the (updated) YesodHttpSig class
This commit is contained in:
fr33domlover
parent
393cce0ede
commit
2a4dc345f4
2 changed files with 63 additions and 136 deletions
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 $
|
||||
|
|
|
|||
Loading…
Reference in a new issue