sup39/vervis
1
0
Fork 0
mirror of https://code.sup39.dev/repos/Wqawg synced 2024-12-29 14:54:51 +09:00
Code Issues 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

114
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
=<< requestFromURI u
)
ExceptT . pure $ do
actor <- first displayException $ getResponseBody response
let uActor = u { uriFragment = "" } let uActor = u { uriFragment = "" }
if uActor == actorId actor if uActor == actorId actor
then then Right ()
else Left "Actor ID doesn't match the keyid URI we fetched"
let pkey = actorPublicKey actor let pkey = actorPublicKey actor
in if publicKeyId pkey == u && publicKeyOwner pkey == actorId actor if publicKeyId pkey == u
then case publicKeyAlgo pkey of then Right ()
Just AlgorithmEd25519 -> else Left "Actor's publicKey's ID doesn't match the keyid URI"
case publicKey $ pemContent $ publicKeyPem pkey of if publicKeyOwner pkey == actorId actor
CryptoPassed k -> then Right ()
case signature sig of else Left "Actor's publicKey's owner doesn't match the actor's ID"
CryptoPassed s -> case publicKeyAlgo pkey of
return $ if verify k input s Nothing ->
then -- HttpSigVerValid Left $
HttpSigVerResult True case malgo of
else -- HttpSigVerInvalid Nothing -> "Algo not given in Sig nor actor"
HttpSigVerResult False Just _ -> "Algo mismatch, Ed25519 in Sig but none in actor"
CryptoFailed e -> -- TODO handle Just algo ->
return $ HttpSigVerResult False case algo of
CryptoFailed e -> -- TODO handle AlgorithmEd25519 -> Right ()
return $ HttpSigVerResult False AlgorithmOther _ ->
_ -> case malgo of Left $
Nothing -> -- return HttpSigVerAlgoNotSupported case malgo of
return $ HttpSigVerResult False Nothing -> "No algo in Sig, unsupported algo in actor"
Just _ -> -- return HttpSigVerAlgoMismatch Just _ -> "Algo mismatch, Ed25519 in Sig but unsupported algo in actor"
return $ HttpSigVerResult False key <- case publicKey $ pemContent $ publicKeyPem pkey of
else -- TODO handle the mismatch CryptoPassed k -> Right k
return $ HttpSigVerResult False CryptoFailed e -> Left "Parsing Ed25519 public key failed"
else -- TODO actor id doesn't match URL we accessed! signature <- case signature sig of
return $ HttpSigVerResult False CryptoPassed s -> Right s
Nothing -> -- return HttpSigVerKeyNotFound CryptoFailed e -> Left "Parsing Ed25519 signature failed"
return $ HttpSigVerResult False if verify key input signature
else -- return HttpSigVerAlgoNotSupported then Right uActor
return $ HttpSigVerResult False else Left "Ed25519 sig verification says not valid"
where
algoSupported Nothing = True
algoSupported (Just a) =
case a of
S.AlgorithmEd25519 -> True
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 $